never executed always true always false
    1 {-|
    2 Module: Flaw.Editor.Entity
    3 Description: Entity level of Oil.
    4 License: MIT
    5 
    6 Entity is a special typeclass of objects which can be stored in Oil repo, edited in Oil editor,
    7 and transmitted via Oil protocol.
    8 
    9 Entity can be serialized into series of key-value records, and deserialized from them.
   10 Each entity instance is identified by 'EntityId', and this entity id is a prefix for every
   11 database record of entity. In other words, all records related to a given entity are key-prefixed
   12 with entity id. Part of record's key after entity id is called /key suffix/ of record.
   13 
   14 Every entity instance has a main record: that's a record with key equal to entity id
   15 (in other words, with null key suffix). Existence of entity instance is determined by
   16 correctness of main record. If there's no main record or its value is incorrect,
   17 entity instance doesn't exist.
   18 
   19 Value of valid main record always starts with fixed-length /entity type id/, which determines
   20 Haskell type of entity. After entity type id there could be other data, depending on type.
   21 
   22 Values of all entity's records constitute entity's data. The only exception is main record:
   23 entity's data includes only part of the value after entity type id.
   24 
   25 Entities can be accessed through means of an additional layer before low-level Oil protocols, namely 'EntityManager'.
   26 'EntityManager' performs conversion between raw records and 'Entity' values and provides caching via 'EntityVar's.
   27 
   28 'EntityVar' is a container for entity value. 'EntityManager' ensures that all alive 'EntityVar's contains up-to-date values
   29 (using weak references to vars). 'EntityVar' also allows for changing a value of an entity's record,
   30 and automatically transmits that change into repo.
   31 
   32 Due to various implementation constraints, not every operation can be done in 'STM' monad. Specifically:
   33 
   34 * Creation of new 'EntityVar' (which includes generating new 'EntityId') or getting an entity var for an existing entity
   35 runs in 'IO' monad.
   36 
   37 * Reading entity value from 'EntityVar' or writing record value runs in 'STM' monad.
   38 
   39 -}
   40 
   41 {-# LANGUAGE ConstraintKinds, DefaultSignatures, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, PatternSynonyms, PolyKinds, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances, ViewPatterns #-}
   42 {-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}
   43 
   44 module Flaw.Editor.Entity
   45   (
   46   -- * Ids
   47     EntityId(..)
   48   , pattern ENTITY_ID_SIZE
   49   , EntityTypeId(..)
   50   , pattern ENTITY_TYPE_ID_SIZE
   51   -- * Entity pointers and vars
   52   , SomeEntityPtr(..)
   53   , EntityPtr(..)
   54   , InterfacedEntityPtr(..)
   55   , SomeEntityVar(..)
   56   , EntityVar(..)
   57   , entityVarEntityId
   58   -- * Entity classes
   59   , Entity(..)
   60   , BasicEntity(..)
   61   , processBasicEntityChange
   62   , applyBasicEntityChange
   63   -- * Entity interfaces
   64   , EntityInterfaceId(..)
   65   , EntityInterface(..)
   66   , EntityInterfaced(..)
   67   -- * Entity containers
   68   , SomeEntity(..)
   69   , SomeBasicEntity(..)
   70   , SomeBasicOrdEntity(..)
   71   , SomeInterfacedEntity(..)
   72   , SomeEntityInterface(..)
   73   -- * Null things
   74   , NullEntity(..)
   75   , nullEntityId
   76   , nullEntityTypeId
   77   , nullEntityInterfaceId
   78   , nullInterfacedEntityPtr
   79   -- * Deserializers
   80   , getRootBaseEntity
   81   , getRootBaseBasicEntity
   82   , getRootBaseBasicOrdEntity
   83   , deserializeEntityInterface
   84   -- * Entity manager
   85   , EntityManager(..)
   86   , GetEntity
   87   , newEntityManager
   88   , unsafePullEntityManager
   89   -- ** Registration
   90   , registerEntityType
   91   , registerBasicEntityType
   92   , registerBasicOrdEntityType
   93   , registerEntityInterface
   94   -- * Entity operations
   95   , getSomeEntityVar
   96   , getEntityVar
   97   , newEntityVar
   98   , readEntityVar
   99   , readSomeEntityVar
  100   , readSomeEntityWithRevisionVar
  101   , writeEntityVarRecord
  102   , writeBasicEntityVar
  103   -- * Entity history
  104   , EntityHistoryChan(..)
  105   , entityVarHistory
  106   , readEntityHistoryChan
  107   -- * Miscellaneous
  108   , EntityException(..)
  109   , GenericEntityChange
  110   , GenericEntityDatatype(..)
  111   , GenericEntityConstructor(..)
  112   , GenericEntitySelector(..)
  113   , GenericEntityValue(..)
  114   -- * TH helpers
  115   , hashTextToEntityId
  116   , hashTextToEntityTypeId
  117   , hashTextToEntityInterfaceId
  118   , interfaceEntityExp
  119   , EntityRegistration(..)
  120   , registerEntitiesAndInterfacesExp
  121   -- * Re-exports for convenience
  122   , Revision
  123   , Proxy(..)
  124   ) where
  125 
  126 import Control.Concurrent.STM
  127 import Control.Exception
  128 import Control.Monad
  129 import Control.Monad.Reader
  130 import qualified Crypto.Random.EntropyPool as C
  131 import qualified Data.ByteArray.Encoding as BA
  132 import qualified Data.ByteString as B
  133 import qualified Data.ByteString.Short as BS
  134 import Data.Default
  135 import Data.IORef
  136 import qualified Data.Map.Strict as M
  137 import qualified Data.Serialize as S
  138 import qualified Data.Text as T
  139 import qualified Data.Text.Encoding as T
  140 import Data.Typeable
  141 import Data.Word
  142 import GHC.Exts(Constraint)
  143 import qualified GHC.Generics as G
  144 import Language.Haskell.TH
  145 import System.Mem.Weak
  146 
  147 import Flaw.Flow
  148 import Flaw.Oil.ClientRepo
  149 import Flaw.Editor.Entity.Internal
  150 import Flaw.Oil.Repo
  151 
  152 -- | Entity id.
  153 newtype EntityId = EntityId BS.ShortByteString deriving (Eq, Ord)
  154 
  155 instance Show EntityId where
  156   show (EntityId entityIdBytes) = "EntityId \"" <> T.unpack (T.decodeUtf8 $ BA.convertToBase BA.Base64 $ BS.fromShort entityIdBytes) <> "\""
  157 
  158 instance Default EntityId where
  159   def = nullEntityId
  160 
  161 -- | Entity id length in bytes.
  162 pattern ENTITY_ID_SIZE = 20
  163 
  164 -- | Null entity id.
  165 {-# NOINLINE nullEntityId #-}
  166 nullEntityId :: EntityId
  167 nullEntityId = EntityId $ BS.toShort $ B.replicate ENTITY_ID_SIZE 0
  168 
  169 instance S.Serialize EntityId where
  170   put (EntityId bytes) = S.putShortByteString bytes
  171   get = EntityId <$> S.getShortByteString ENTITY_ID_SIZE
  172 
  173 -- | Entity type id.
  174 newtype EntityTypeId = EntityTypeId BS.ShortByteString deriving (Eq, Ord, Semigroup, Monoid, Show)
  175 
  176 -- | Entity type id length in bytes.
  177 pattern ENTITY_TYPE_ID_SIZE = 20
  178 
  179 -- | Null entity type id.
  180 {-# NOINLINE nullEntityTypeId #-}
  181 nullEntityTypeId :: EntityTypeId
  182 nullEntityTypeId = EntityTypeId BS.empty
  183 
  184 instance S.Serialize EntityTypeId where
  185   put (EntityTypeId bytes) = S.putShortByteString bytes
  186   get = EntityTypeId <$> S.getShortByteString ENTITY_ID_SIZE
  187 
  188 -- | Entity "pointer" is a typed entity id.
  189 -- Doesn't keep a reference to cached entity.
  190 -- You can read or write entity by entity pointer in IO monad.
  191 newtype EntityPtr (a :: *) = EntityPtr EntityId deriving (Eq, Ord, S.Serialize, Default, Show)
  192 
  193 -- | Untyped entity var, stores cached entity.
  194 -- Entity manager keeps updating the var until it's GC'ed.
  195 data SomeEntityVar = SomeEntityVar
  196   { someEntityVarEntityManager :: !EntityManager
  197   , someEntityVarEntityId :: !EntityId
  198   , someEntityVarValueVar :: {-# UNPACK #-} !(TVar EntityValue)
  199   }
  200 
  201 -- | Typed entity var.
  202 newtype EntityVar (a :: *) = EntityVar SomeEntityVar
  203 
  204 -- | Get entity id from entity var.
  205 entityVarEntityId :: EntityVar a -> EntityId
  206 entityVarEntityId (EntityVar SomeEntityVar
  207   { someEntityVarEntityId = entityId
  208   }) = entityId
  209 
  210 -- | Entity value, stored in entity var.
  211 data EntityValue = EntityValue
  212   { entityValueEntity :: !SomeEntity
  213   , entityValueRevision :: {-# UNPACK #-} !Revision
  214   , entityValueHistoryVar :: {-# UNPACK #-} !(TVar EntityHistory)
  215   }
  216 
  217 -- | This is basically own implementation for broadcast `TChan`.
  218 data EntityHistory where
  219   EntityHistoryEnd :: EntityHistory
  220   EntityHistoryChange :: Entity a =>
  221     { entityHistoryRevision :: {-# UNPACK #-} !Revision
  222     , entityHistoryEntity :: !a
  223     , entityHistoryChange :: !(EntityChange a)
  224     , entityHistoryNextVar :: {-# UNPACK #-} !(TVar EntityHistory)
  225     } -> EntityHistory
  226   EntityHistoryTypeChange :: Entity a =>
  227     { entityHistoryRevision :: {-# UNPACK #-} !Revision
  228     , entityHistoryEntity :: !a
  229     , entityHistoryNextVar :: {-# UNPACK #-} !(TVar EntityHistory)
  230     } -> EntityHistory
  231 
  232 writeEntityChange :: Entity a => TVar EntityValue -> Revision -> a -> EntityChange a -> STM ()
  233 writeEntityChange valueVar revision entity change = do
  234   nextHistoryVar <- newTVar EntityHistoryEnd
  235   entityValue@EntityValue
  236     { entityValueHistoryVar = historyVar
  237     } <- readTVar valueVar
  238   writeTVar historyVar EntityHistoryChange
  239     { entityHistoryRevision = revision
  240     , entityHistoryEntity = entity
  241     , entityHistoryChange = change
  242     , entityHistoryNextVar = nextHistoryVar
  243     }
  244   writeTVar valueVar entityValue
  245     { entityValueEntity = SomeEntity entity
  246     , entityValueRevision = revision
  247     , entityValueHistoryVar = nextHistoryVar
  248     }
  249 
  250 writeEntityTypeChange :: Entity a => TVar EntityValue -> Revision -> a -> STM ()
  251 writeEntityTypeChange valueVar revision entity = do
  252   nextHistoryVar <- newTVar EntityHistoryEnd
  253   entityValue@EntityValue
  254     { entityValueHistoryVar = historyVar
  255     } <- readTVar valueVar
  256   writeTVar historyVar EntityHistoryTypeChange
  257     { entityHistoryRevision = revision
  258     , entityHistoryEntity = entity
  259     , entityHistoryNextVar = nextHistoryVar
  260     }
  261   writeTVar valueVar entityValue
  262     { entityValueEntity = SomeEntity entity
  263     , entityValueRevision = revision
  264     , entityValueHistoryVar = nextHistoryVar
  265     }
  266 
  267 -- | Untyped entity pointer.
  268 newtype SomeEntityPtr a = SomeEntityPtr EntityId deriving S.Serialize
  269 
  270 -- | Class of repo entity.
  271 -- Entity should be able to deserialize from any data.
  272 -- It must not throw exceptions. It's free to ignore invalid data
  273 -- and/or provide some default values instead.
  274 class Typeable a => Entity (a :: *) where
  275 
  276   {-# MINIMAL getEntityTypeId #-}
  277 
  278   -- | Type representing change to entity.
  279   type EntityChange a :: *
  280   type EntityChange a = GenericEntityChange a
  281 
  282   -- | Return type id of entity.
  283   -- Parameter is not used and can be 'undefined'.
  284   getEntityTypeId :: a -> EntityTypeId
  285 
  286   -- | Process change in entity's data.
  287   -- Changes of one specific record (with fixed key) constitute a group.
  288   -- Changes to different records are commutative.
  289   -- Must not throw exceptions.
  290   -- Invalid values must be processed as well as valid,
  291   -- keeping all the laws above, possibly recording some error state into entity.
  292   processEntityChange
  293     :: a -- ^ Current entity value.
  294     -> B.ByteString -- ^ Key suffix of changed record.
  295     -> B.ByteString -- ^ New value of changed record.
  296     -> Maybe (a, EntityChange a)
  297   default processEntityChange :: (G.Generic a, GenericEntityDatatype (G.Rep a), EntityChange a ~ GenericEntityChange a) => a -> B.ByteString -> B.ByteString -> Maybe (a, EntityChange a)
  298   processEntityChange oldEntity keySuffix newValue = do -- Maybe monad
  299     (newEntity, change) <- processGenericEntityDatatypeChange (G.from oldEntity) keySuffix newValue
  300     return (G.to newEntity, change)
  301 
  302   -- | Apply change to get new entity and write changes to entity var.
  303   applyEntityChange
  304     :: EntityVar a -- ^ Entity var.
  305     -> EntityChange a -- ^ Entity change.
  306     -> STM ()
  307   default applyEntityChange :: (G.Generic a, GenericEntityDatatype (G.Rep a), EntityChange a ~ GenericEntityChange a) => EntityVar a -> EntityChange a -> STM ()
  308   applyEntityChange = applyGenericEntityDatatypeChange
  309 
  310   -- | Return witness for entity that it supports specified entity interface.
  311   interfaceEntity :: EntityInterface i => Proxy i -> a -> EntityInterfaced i a
  312   interfaceEntity _ _ = EntityNotInterfaced
  313 
  314   -- | Return some short human-friendly textual representation of entity.
  315   entityToText :: a -> T.Text
  316   default entityToText :: Show a => a -> T.Text
  317   entityToText = T.pack . show
  318 
  319 -- | Basic entity is an entity consisting of main record only.
  320 class (Entity a, EntityChange a ~ a) => BasicEntity a where
  321   -- | Serialize basic entity into main record's value.
  322   serializeBasicEntity :: a -> B.ByteString
  323   default serializeBasicEntity :: S.Serialize a => a -> B.ByteString
  324   serializeBasicEntity = S.encode
  325 
  326   -- | Deserialize basic entity from main record's value.
  327   deserializeBasicEntity :: B.ByteString -> a
  328   default deserializeBasicEntity :: (S.Serialize a, Default a) => B.ByteString -> a
  329   deserializeBasicEntity bytes = case S.decode bytes of
  330     Left _e -> def
  331     Right r -> r
  332 
  333 -- | Implementation of 'processEntityChange' for 'BasicEntity'es.
  334 processBasicEntityChange :: BasicEntity a => a -> B.ByteString -> B.ByteString -> Maybe (a, a)
  335 processBasicEntityChange _oldEntity changedKeySuffix newValue =
  336   if B.null changedKeySuffix then
  337     let newEntity = deserializeBasicEntity newValue in Just (newEntity, newEntity)
  338   else Nothing
  339 
  340 -- | Implementation of 'applyEntityChange' for 'BasicEntity'es.
  341 applyBasicEntityChange :: BasicEntity a => EntityVar a -> a -> STM ()
  342 applyBasicEntityChange = writeBasicEntityVar
  343 
  344 -- | Container for any entity.
  345 data SomeEntity where
  346   SomeEntity :: Entity a => a -> SomeEntity
  347 
  348 -- | Container for basic entity.
  349 data SomeBasicEntity where
  350   SomeBasicEntity :: BasicEntity a => a -> SomeBasicEntity
  351 
  352 -- | Container for basic ordered entity.
  353 data SomeBasicOrdEntity where
  354   SomeBasicOrdEntity :: (BasicEntity a, Ord a) => a -> SomeBasicOrdEntity
  355 
  356 -- | Null entity, used when no entity could be deserialized.
  357 data NullEntity = NullEntity deriving (Typeable, Show)
  358 
  359 instance Entity NullEntity where
  360   getEntityTypeId _ = nullEntityTypeId
  361   processEntityChange NullEntity _ _ = Nothing
  362   applyEntityChange _ _ = return ()
  363 
  364 instance Default NullEntity where
  365   def = NullEntity
  366 
  367 -- | Entity interface id.
  368 newtype EntityInterfaceId = EntityInterfaceId BS.ShortByteString deriving (Eq, Ord)
  369 
  370 instance Show EntityInterfaceId where
  371   show (EntityInterfaceId entityInterfaceIdBytes) = "EntityInterfaceId \"" <> T.unpack (T.decodeUtf8 $ BA.convertToBase BA.Base64 $ BS.fromShort entityInterfaceIdBytes) <> "\""
  372 
  373 instance Default EntityInterfaceId where
  374   def = nullEntityInterfaceId
  375 
  376 -- | Entity interface id length in bytes.
  377 pattern ENTITY_INTERFACE_ID_SIZE = 20
  378 
  379 -- | Null entity interface id.
  380 {-# NOINLINE nullEntityInterfaceId #-}
  381 nullEntityInterfaceId :: EntityInterfaceId
  382 nullEntityInterfaceId = EntityInterfaceId $ BS.toShort $ B.replicate ENTITY_INTERFACE_ID_SIZE 0
  383 
  384 instance S.Serialize EntityInterfaceId where
  385   put (EntityInterfaceId bytes) = S.putShortByteString bytes
  386   get = EntityInterfaceId <$> S.getShortByteString ENTITY_INTERFACE_ID_SIZE
  387 
  388 -- | Class of entity interface.
  389 -- Entity interface is itself a class.
  390 class Typeable i => EntityInterface (i :: * -> Constraint) where
  391   -- | Get id of entity interface.
  392   getEntityInterfaceId :: p i -> EntityInterfaceId
  393 
  394 -- | Witness for entity having an interface.
  395 data EntityInterfaced i a where
  396   EntityInterfaced :: (EntityInterface i, Entity a, i a) => EntityInterfaced i a
  397   EntityNotInterfaced :: EntityInterfaced i a
  398 
  399 -- | Some entity supporting specified interface.
  400 data SomeInterfacedEntity i where
  401   SomeInterfacedEntity :: (EntityInterface i, Entity a, i a) => a -> SomeInterfacedEntity i
  402 
  403 -- | Entity pointer pointing at some entity which supports specified interface.
  404 newtype InterfacedEntityPtr (i :: * -> Constraint) = InterfacedEntityPtr EntityId deriving (Eq, Ord, S.Serialize, Default, Show)
  405 
  406 -- | Some entity interface.
  407 data SomeEntityInterface where
  408   SomeEntityInterface :: EntityInterface i => Proxy i -> SomeEntityInterface
  409 
  410 nullInterfacedEntityPtr :: InterfacedEntityPtr a
  411 nullInterfacedEntityPtr = InterfacedEntityPtr nullEntityId
  412 
  413 -- | Entity manager based on client repo.
  414 data EntityManager = EntityManager
  415   {
  416   -- | Every client repo operation must be performed in this flow,
  417   -- even not performed by entity manager itself.
  418     entityManagerFlow :: !Flow
  419   , entityManagerClientRepo :: !ClientRepo
  420   -- | Push action, signal that client repo has client-side changes.
  421   -- Called by entity manager in the flow.
  422   , entityManagerPushAction :: !(IO ())
  423   -- | Entropy pool to generate new entity ids.
  424   , entityManagerEntropyPool :: !C.EntropyPool
  425   , entityManagerNextTagRef :: {-# UNPACK #-} !(IORef Int)
  426   , entityManagerCacheRef :: {-# UNPACK #-} !(IORef (M.Map EntityId CachedEntity))
  427   -- | Entity deserialization functions.
  428   , entityManagerDeserializatorsRef :: {-# UNPACK #-} !(IORef (M.Map EntityTypeId (GetEntity SomeEntity)))
  429   -- | Basic entity deserialization functions.
  430   , entityManagerBasicDeserializatorsRef :: {-# UNPACK #-} !(IORef (M.Map EntityTypeId (GetEntity SomeBasicEntity)))
  431   -- | Basic ordered entity deserialization functions.
  432   , entityManagerBasicOrdDeserializatorsRef :: {-# UNPACK #-} !(IORef (M.Map EntityTypeId (GetEntity SomeBasicOrdEntity)))
  433   -- | Entity interfaces.
  434   , entityManagerEntityInterfacesRef :: {-# UNPACK #-} !(IORef (M.Map EntityInterfaceId (GetEntity SomeEntityInterface)))
  435   -- | Dirty entities.
  436   , entityManagerDirtyRecordsVar :: {-# UNPACK #-} !(TVar (M.Map B.ByteString B.ByteString))
  437   -- | Is push scheduled?
  438   , entityManagerPushScheduledVar :: {-# UNPACK #-} !(TVar Bool)
  439   }
  440 
  441 -- | Monad for deserializing entities.
  442 type GetEntity = ReaderT GetEntityState S.Get
  443 
  444 data GetEntityState = GetEntityState
  445   { getEntityStateGetter :: !(S.Get SomeEntity)
  446   , getEntityStateBasicGetter :: !(S.Get SomeBasicEntity)
  447   , getEntityStateBasicOrdGetter :: !(S.Get SomeBasicOrdEntity)
  448   , getEntityStateInterfaceGetter :: !(S.Get SomeEntityInterface)
  449   }
  450 
  451 -- | Deserialize entity type and get base entity for this type.
  452 getRootBaseEntity :: GetEntity SomeEntity
  453 getRootBaseEntity = lift . getEntityStateGetter =<< ask
  454 
  455 -- | Deserialize entity type and get basic base entity for this type.
  456 getRootBaseBasicEntity :: GetEntity SomeBasicEntity
  457 getRootBaseBasicEntity = lift . getEntityStateBasicGetter =<< ask
  458 
  459 -- | Deserialize entity type and get basic ordered base entity for this type.
  460 getRootBaseBasicOrdEntity :: GetEntity SomeBasicOrdEntity
  461 getRootBaseBasicOrdEntity = lift . getEntityStateBasicOrdGetter =<< ask
  462 
  463 -- | Deserialize entity interface.
  464 deserializeEntityInterface :: GetEntity SomeEntityInterface
  465 deserializeEntityInterface = lift . getEntityStateInterfaceGetter =<< ask
  466 
  467 -- | Entity in cache.
  468 data CachedEntity = CachedEntity
  469   { cachedEntityTag :: {-# UNPACK #-} !Int
  470   , cachedEntityWeak :: {-# UNPACK #-} !(Weak (TVar EntityValue))
  471   }
  472 
  473 -- | Initialize entity manager.
  474 newEntityManager
  475   :: Flow -- ^ Flow to run operations in.
  476   -> ClientRepo -- ^ Underlying client repo.
  477   -> IO () -- ^ Push action.
  478   -> IO EntityManager
  479 newEntityManager flow clientRepo pushAction = do
  480   entropyPool <- C.createEntropyPool
  481   nextTagRef <- newIORef 0
  482   cacheRef <- newIORef M.empty
  483   deserializatorsRef <- newIORef M.empty
  484   basicDeserializatorsRef <- newIORef M.empty
  485   basicOrdDeserializatorsRef <- newIORef M.empty
  486   entityInterfacesRef <- newIORef M.empty
  487   dirtyRecordsVar <- newTVarIO M.empty
  488   pushScheduledVar <- newTVarIO False
  489   return EntityManager
  490     { entityManagerFlow = flow
  491     , entityManagerClientRepo = clientRepo
  492     , entityManagerPushAction = pushAction
  493     , entityManagerEntropyPool = entropyPool
  494     , entityManagerNextTagRef = nextTagRef
  495     , entityManagerCacheRef = cacheRef
  496     , entityManagerDeserializatorsRef = deserializatorsRef
  497     , entityManagerBasicDeserializatorsRef = basicDeserializatorsRef
  498     , entityManagerBasicOrdDeserializatorsRef = basicOrdDeserializatorsRef
  499     , entityManagerEntityInterfacesRef = entityInterfacesRef
  500     , entityManagerDirtyRecordsVar = dirtyRecordsVar
  501     , entityManagerPushScheduledVar = pushScheduledVar
  502     }
  503 
  504 -- | Register entity type.
  505 registerEntityType :: EntityManager -> EntityTypeId -> (GetEntity SomeEntity) -> IO ()
  506 registerEntityType EntityManager
  507   { entityManagerDeserializatorsRef = deserializatorsRef
  508   } entityTypeId = modifyIORef' deserializatorsRef . M.insert entityTypeId
  509 
  510 -- | Register basic entity type.
  511 registerBasicEntityType :: EntityManager -> EntityTypeId -> (GetEntity SomeBasicEntity) -> IO ()
  512 registerBasicEntityType entityManager@EntityManager
  513   { entityManagerBasicDeserializatorsRef = basicDeserializatorsRef
  514   } entityTypeId deserializator = do
  515   modifyIORef' basicDeserializatorsRef $ M.insert entityTypeId deserializator
  516   registerEntityType entityManager entityTypeId $ do
  517     SomeBasicEntity entity <- deserializator
  518     return $ SomeEntity entity
  519 
  520 -- | Register basic ordered entity type.
  521 registerBasicOrdEntityType :: EntityManager -> EntityTypeId -> (GetEntity SomeBasicOrdEntity) -> IO ()
  522 registerBasicOrdEntityType entityManager@EntityManager
  523   { entityManagerBasicOrdDeserializatorsRef = basicOrdDeserializatorsRef
  524   } entityTypeId deserializator = do
  525   modifyIORef' basicOrdDeserializatorsRef $ M.insert entityTypeId deserializator
  526   registerBasicEntityType entityManager entityTypeId $ do
  527     SomeBasicOrdEntity entity <- deserializator
  528     return $ SomeBasicEntity entity
  529 
  530 -- | Register entity interface.
  531 registerEntityInterface :: EntityManager -> EntityInterfaceId -> (GetEntity SomeEntityInterface) -> IO ()
  532 registerEntityInterface EntityManager
  533   { entityManagerEntityInterfacesRef = entityInterfacesRef
  534   } entityInterfaceId = modifyIORef' entityInterfacesRef . M.insert entityInterfaceId
  535 
  536 internalGetEntityState :: EntityManager -> IO GetEntityState
  537 internalGetEntityState EntityManager
  538   { entityManagerDeserializatorsRef = deserializatorsRef
  539   , entityManagerBasicDeserializatorsRef = basicDeserializatorsRef
  540   , entityManagerBasicOrdDeserializatorsRef = basicOrdDeserializatorsRef
  541   , entityManagerEntityInterfacesRef = entityInterfacesRef
  542   } = do
  543   deserializators <- readIORef deserializatorsRef
  544   basicDeserializators <- readIORef basicDeserializatorsRef
  545   basicOrdDeserializators <- readIORef basicOrdDeserializatorsRef
  546   entityInterfaces <- readIORef entityInterfacesRef
  547   let
  548     f :: M.Map EntityTypeId (GetEntity a) -> S.Get a
  549     f ds = do
  550       firstEntityTypeId <- S.get
  551       case M.lookup firstEntityTypeId ds of
  552         Just deserializator -> runReaderT deserializator s
  553         Nothing -> fail "unknown entity type id"
  554     s = GetEntityState
  555       { getEntityStateGetter = f deserializators
  556       , getEntityStateBasicGetter = f basicDeserializators
  557       , getEntityStateBasicOrdGetter = f basicOrdDeserializators
  558       , getEntityStateInterfaceGetter = do
  559         entityInterfaceId <- S.get
  560         case M.lookup entityInterfaceId entityInterfaces of
  561           Just deserializator -> runReaderT deserializator s
  562           Nothing -> fail "unknown entity interface id"
  563       }
  564   return s
  565 
  566 -- | Combine revisions of entity's records to get entity's revision.
  567 combineRevisions :: Revision -> Revision -> Revision
  568 combineRevisions a b = if a > 0 && b > 0 then max a b else 0
  569 
  570 -- | Deserialize entity.
  571 deserializeSomeEntity :: EntityManager -> EntityId -> IO (Revision, SomeEntity)
  572 deserializeSomeEntity entityManager@EntityManager
  573   { entityManagerClientRepo = clientRepo
  574   } (EntityId (BS.fromShort -> entityIdBytes)) = do
  575   (mainRecordRevision, mainValue) <- clientRepoGetRevisionValue clientRepo entityIdBytes
  576   getEntity <- getEntityStateGetter <$> internalGetEntityState entityManager
  577   let
  578     eitherReturnResult = flip S.runGet mainValue $ do
  579       SomeEntity baseEntity <- getEntity
  580       mainValueSuffix <- S.getBytes =<< S.remaining
  581       return $ do
  582         let
  583           f (revision, entity) key = do
  584             (recordRevision, value) <-
  585               if key == entityIdBytes then return (mainRecordRevision, mainValueSuffix)
  586               else clientRepoGetRevisionValue clientRepo key
  587             return
  588               ( combineRevisions revision recordRevision
  589               , maybe entity fst $ processEntityChange entity (B.drop (B.length entityIdBytes) key) value
  590               )
  591         (revision, entity) <- foldM f (mainRecordRevision, baseEntity) =<< clientRepoGetKeysPrefixed clientRepo entityIdBytes
  592         return (revision, SomeEntity entity)
  593   case eitherReturnResult of
  594     Left _ -> return (0, SomeEntity NullEntity)
  595     Right returnResult -> returnResult
  596 
  597 -- | Provide entity manager with changes pulled from remote repo.
  598 -- Must be called in entity manager's flow, in the same task as pulling changes into client repo.
  599 unsafePullEntityManager :: EntityManager -> [(Revision, B.ByteString, B.ByteString)] -> IO ()
  600 unsafePullEntityManager entityManager@EntityManager
  601   { entityManagerClientRepo = clientRepo
  602   , entityManagerCacheRef = cacheRef
  603   , entityManagerDirtyRecordsVar = dirtyRecordsVar
  604   } changes = do
  605   getEntity <- getEntityStateGetter <$> internalGetEntityState entityManager
  606   forM_ (filter ((>= ENTITY_ID_SIZE) . B.length) $ map (\(_revision, key, _value) -> key) changes) $ \recordKey -> do
  607     -- get entity id
  608     let
  609       (entityIdBytes, recordKeySuffix) = B.splitAt ENTITY_ID_SIZE recordKey
  610       entityId = EntityId $ BS.toShort entityIdBytes
  611     -- get cached entity
  612     cache <- readIORef cacheRef
  613     case M.lookup entityId cache of
  614       Just CachedEntity
  615         { cachedEntityWeak = weak
  616         } -> do
  617         maybeEntityVar <- deRefWeak weak
  618         case maybeEntityVar of
  619           Just entityVar -> do
  620             -- note that changes from pull info contain server value,
  621             -- i.e. it doesn't include non-pushed-yet changes on client side
  622             -- so we need to read real value from client repo
  623             (recordRevision, recordValue) <- clientRepoGetRevisionValue clientRepo recordKey
  624             join $ atomically $ do
  625               -- update entity only if record is not dirty
  626               dirtyRecords <- readTVar dirtyRecordsVar
  627               if M.member recordKey dirtyRecords then return $ return ()
  628               else do
  629                 entityValue@EntityValue
  630                   { entityValueEntity = SomeEntity entity
  631                   } <- readTVar entityVar
  632                 -- if it's main record
  633                 if B.null recordKeySuffix then let
  634                   -- get new entity type id
  635                   getter = do
  636                     SomeEntity baseEntity <- getEntity
  637                     -- if entity type id hasn't changed, simply process change
  638                     if getEntityTypeId entity == getEntityTypeId baseEntity then do
  639                       newValueSuffix <- S.getBytes =<< S.remaining
  640                       return $ do
  641                         case processEntityChange entity B.empty newValueSuffix of
  642                           Just (newEntity, entityChange) -> writeEntityChange entityVar recordRevision newEntity entityChange
  643                           Nothing -> return ()
  644                         return $ return ()
  645                     else return $ return $ do
  646                       -- re-deserialize it completely
  647                       -- we have to do it via two STM transactions. between these transactions
  648                       -- the only thing which can happen is user will write something into entity var (not changing a type)
  649                       -- it will be useless anyway, and typed entity var will have to be re-typed at least
  650                       -- so hopefully it's ok to do two transactions
  651                       (newRevision, SomeEntity newEntity) <- deserializeSomeEntity entityManager entityId
  652                       atomically $ writeEntityTypeChange entityVar newRevision newEntity
  653                   in case S.runGet getter recordValue of
  654                     Right stm -> stm
  655                     Left _e -> do
  656                       writeTVar entityVar entityValue
  657                         { entityValueEntity = SomeEntity NullEntity
  658                         }
  659                       return $ return ()
  660                 -- else it's non-main record
  661                 else do
  662                   -- simply process change
  663                   case processEntityChange entity recordKeySuffix recordValue of
  664                     Just (newEntity, entityChange) -> writeEntityChange entityVar recordRevision newEntity entityChange
  665                     Nothing -> return ()
  666                   return $ return ()
  667           Nothing ->
  668             -- expired cached entity, remove it
  669             writeIORef cacheRef $ M.delete entityId cache
  670       Nothing -> return ()
  671 
  672 scheduleEntityManagerPush :: EntityManager -> STM ()
  673 scheduleEntityManagerPush EntityManager
  674   { entityManagerFlow = flow
  675   , entityManagerClientRepo = clientRepo
  676   , entityManagerPushAction = pushAction
  677   , entityManagerDirtyRecordsVar = dirtyRecordsVar
  678   , entityManagerPushScheduledVar = pushScheduledVar
  679   } = do
  680   -- only one push must be scheduled at all times
  681   pushScheduled <- readTVar pushScheduledVar
  682   unless pushScheduled $ do
  683     writeTVar pushScheduledVar True
  684     asyncRunInFlow flow $ do
  685       -- atomically get dirty records
  686       dirtyRecords <- atomically $ do
  687         -- get dirty entities and clear them
  688         dirtyRecords <- readTVar dirtyRecordsVar
  689         writeTVar dirtyRecordsVar $ M.empty
  690         -- reset scheduled state in the same transaction
  691         writeTVar pushScheduledVar False
  692         return dirtyRecords
  693       -- write dirty records
  694       forM_ (M.toList dirtyRecords) $ \(key, value) -> clientRepoChange clientRepo key value
  695       -- run push action
  696       pushAction
  697 
  698 cacheEntity :: EntityManager -> EntityId -> IO SomeEntityVar
  699 cacheEntity entityManager@EntityManager
  700   { entityManagerFlow = flow
  701   , entityManagerNextTagRef = nextTagRef
  702   , entityManagerCacheRef = cacheRef
  703   } entityId = do
  704   -- get initial value of entity
  705   (revision, entity) <- deserializeSomeEntity entityManager entityId
  706   -- create new var
  707   tag <- atomicModifyIORef' nextTagRef $ \nextVarId -> (nextVarId + 1, nextVarId)
  708   historyVar <- newTVarIO EntityHistoryEnd
  709   entityVar <- newTVarIO EntityValue
  710     { entityValueEntity = entity
  711     , entityValueRevision = revision
  712     , entityValueHistoryVar = historyVar
  713     }
  714   -- put it into cache
  715   weak <- mkWeakTVar entityVar $ weakFinalizer tag
  716   modifyIORef' cacheRef $ M.insert entityId CachedEntity
  717     { cachedEntityTag = tag
  718     , cachedEntityWeak = weak
  719     }
  720   return SomeEntityVar
  721     { someEntityVarEntityManager = entityManager
  722     , someEntityVarEntityId = entityId
  723     , someEntityVarValueVar = entityVar
  724     }
  725   where
  726     -- finalizer for weak references
  727     weakFinalizer tag = atomically $ asyncRunInFlow flow $ do
  728       cache <- readIORef cacheRef
  729       case M.lookup entityId cache of
  730         Just CachedEntity
  731           { cachedEntityTag = t
  732           } -> when (tag == t) $ writeIORef cacheRef $ M.delete entityId cache
  733         Nothing -> return ()
  734 
  735 -- | Get untyped entity var for given entity id.
  736 getSomeEntityVar :: EntityManager -> EntityId -> IO SomeEntityVar
  737 getSomeEntityVar entityManager@EntityManager
  738   { entityManagerFlow = flow
  739   , entityManagerCacheRef = cacheRef
  740   } entityId = runInFlow flow $ do
  741 
  742   cache <- readIORef cacheRef
  743 
  744   -- function to create new cached entity var
  745   let cacheExistingEntityVar = cacheEntity entityManager entityId
  746 
  747   -- check if there's cached entity
  748   case M.lookup entityId cache of
  749     -- if there's a cached var
  750     Just CachedEntity
  751       { cachedEntityWeak = weak
  752       } -> do
  753       -- check if it's alive
  754       maybeEntityVar <- deRefWeak weak
  755       case maybeEntityVar of
  756         -- if it's still alive, return it
  757         Just entityVar -> return SomeEntityVar
  758           { someEntityVarEntityManager = entityManager
  759           , someEntityVarEntityId = entityId
  760           , someEntityVarValueVar = entityVar
  761           }
  762         -- otherwise cached var has been garbage collected
  763         Nothing -> cacheExistingEntityVar
  764     -- otherwise there's no cached var
  765     Nothing -> cacheExistingEntityVar
  766 
  767 -- | Get typed entity var for given entity id.
  768 getEntityVar :: EntityManager -> EntityId -> IO (EntityVar a)
  769 getEntityVar entityManager entityId = EntityVar <$> getSomeEntityVar entityManager entityId
  770 
  771 -- | Generate entity id and create new entity var.
  772 -- Generated entity is "empty", i.e. contains NullEntity.
  773 newEntityVar :: Entity a => EntityManager -> IO (EntityVar a)
  774 newEntityVar entityManager@EntityManager
  775   { entityManagerFlow = flow
  776   , entityManagerClientRepo = clientRepo
  777   , entityManagerPushAction = pushAction
  778   , entityManagerEntropyPool = entropyPool
  779   } = runInFlow flow $ f undefined where
  780   f :: Entity a => a -> IO (EntityVar a)
  781   f u = do
  782     -- generate entity id
  783     entityIdBytes <- C.getEntropyFrom entropyPool ENTITY_ID_SIZE
  784     -- write entity type id
  785     let EntityTypeId entityTypeIdBytes = getEntityTypeId u
  786     clientRepoChange clientRepo entityIdBytes $ BS.fromShort entityTypeIdBytes
  787     pushAction
  788     -- create cached entity var
  789     EntityVar <$> cacheEntity entityManager (EntityId $ BS.toShort entityIdBytes)
  790 
  791 -- | Read entity var type safely.
  792 -- If entity var contains entity of wrong type, throws EntityWrongTypeException.
  793 readEntityVar :: Entity a => EntityVar a -> STM a
  794 readEntityVar (EntityVar someEntityVar) = do
  795   SomeEntity entity <- readSomeEntityVar someEntityVar
  796   case cast entity of
  797     Just correctEntity -> return correctEntity
  798     Nothing -> throwSTM EntityWrongTypeException
  799 
  800 -- | Read untyped entity from var.
  801 readSomeEntityVar :: SomeEntityVar -> STM SomeEntity
  802 readSomeEntityVar SomeEntityVar
  803   { someEntityVarValueVar = valueVar
  804   } = entityValueEntity <$> readTVar valueVar
  805 
  806 -- | Read untyped entity and revision from var.
  807 readSomeEntityWithRevisionVar :: SomeEntityVar -> STM (SomeEntity, Revision)
  808 readSomeEntityWithRevisionVar SomeEntityVar
  809   { someEntityVarValueVar = valueVar
  810   } = do
  811   EntityValue
  812     { entityValueEntity = someEntity
  813     , entityValueRevision = revision
  814     } <- readTVar valueVar
  815   return (someEntity, revision)
  816 
  817 -- | Write record for entity var.
  818 -- Current entity in the var must be of the correct type.
  819 writeEntityVarRecord :: Entity a => EntityVar a -> B.ByteString -> B.ByteString -> STM ()
  820 writeEntityVarRecord entityVar@(EntityVar SomeEntityVar
  821   { someEntityVarEntityManager = entityManager@EntityManager
  822     { entityManagerDirtyRecordsVar = dirtyRecordsVar
  823     }
  824   , someEntityVarEntityId = EntityId entityIdBytes
  825   , someEntityVarValueVar = entityValueVar
  826   }) recordKeySuffix recordNewValue = do
  827   -- get entity
  828   EntityValue
  829     { entityValueEntity = SomeEntity entity
  830     } <- readTVar entityValueVar
  831   -- check that current entity is the same as entity var underlying type
  832   let
  833     castEntityForVar :: (Typeable a, Typeable b) => EntityVar a -> b -> Maybe a
  834     castEntityForVar _ = cast
  835   case castEntityForVar entityVar entity of
  836     -- if entity is of the same type, simply apply the change
  837     Just entityOfVarType -> case processEntityChange entityOfVarType recordKeySuffix recordNewValue of
  838       Just (newEntity, entityChange) -> do
  839         -- write to var
  840         writeEntityChange entityValueVar 0 newEntity entityChange
  841         -- write record
  842         let
  843           newRecordValue =
  844             if B.null recordKeySuffix then let
  845               EntityTypeId entityTypeIdBytes = getEntityTypeId newEntity
  846               in BS.fromShort entityTypeIdBytes <> recordNewValue
  847             else recordNewValue
  848         modifyTVar' dirtyRecordsVar $ M.insert (BS.fromShort entityIdBytes <> recordKeySuffix) newRecordValue
  849       Nothing -> return ()
  850     -- else entity is of another type
  851     Nothing -> throwSTM EntityWrongTypeException
  852   -- schedule push
  853   scheduleEntityManagerPush entityManager
  854 
  855 -- | Write basic entity into entity var.
  856 -- Entity is replaced completely. Var may contain entity of wrong type prior to operation.
  857 writeBasicEntityVar :: BasicEntity a => EntityVar a -> a -> STM ()
  858 writeBasicEntityVar (EntityVar SomeEntityVar
  859   { someEntityVarEntityManager = entityManager@EntityManager
  860     { entityManagerDirtyRecordsVar = dirtyRecordsVar
  861     }
  862   , someEntityVarEntityId = EntityId entityIdBytes
  863   , someEntityVarValueVar = entityValueVar
  864   }) newEntity = do
  865   -- modify var
  866   writeEntityChange entityValueVar 0 newEntity newEntity
  867   -- write record
  868   let EntityTypeId entityTypeIdBytes = getEntityTypeId newEntity
  869   modifyTVar' dirtyRecordsVar $ M.insert (BS.fromShort entityIdBytes) $ BS.fromShort entityTypeIdBytes <> serializeBasicEntity newEntity
  870   -- schedule push
  871   scheduleEntityManagerPush entityManager
  872 
  873 -- | Entity history chan is a stream of changes to entity.
  874 newtype EntityHistoryChan a = EntityHistoryChan (TVar (TVar EntityHistory))
  875 
  876 -- | Get entity's history chan.
  877 entityVarHistory :: Typeable a => EntityVar a -> STM (EntityHistoryChan a)
  878 entityVarHistory (EntityVar SomeEntityVar
  879   { someEntityVarValueVar = valueVar
  880   }) = do
  881   EntityValue
  882     { entityValueEntity = SomeEntity entity
  883     , entityValueHistoryVar = historyVar
  884     } <- readTVar valueVar
  885   -- check that entity is of correct type
  886   let
  887     f :: a -> STM (EntityHistoryChan a)
  888     f _ = EntityHistoryChan <$> newTVar historyVar
  889   case cast entity of
  890     Just castedEntity -> f castedEntity
  891     Nothing -> throwSTM EntityWrongTypeException
  892 
  893 -- | Get history event.
  894 -- Retries if no history event available.
  895 -- Throws `EntityWrongTypeException` on type change events,
  896 -- or if entity is of wrong type.
  897 readEntityHistoryChan :: Typeable a => EntityHistoryChan a -> STM (a, EntityChange a)
  898 readEntityHistoryChan (EntityHistoryChan chanVar) = do
  899   historyVar <- readTVar chanVar
  900   history <- readTVar historyVar
  901   case history of
  902     EntityHistoryEnd -> retry
  903     EntityHistoryChange
  904       { entityHistoryEntity = entity
  905       , entityHistoryChange = change
  906       , entityHistoryNextVar = nextHistoryVar
  907       } -> let
  908       f :: Maybe (a :~: b) -> a -> EntityChange a -> STM (b, EntityChange b)
  909       f q e ec = case q of
  910         Just Refl -> do
  911           writeTVar chanVar nextHistoryVar
  912           return (e, ec)
  913         Nothing -> throwSTM EntityWrongTypeException
  914       in f eqT entity change
  915     EntityHistoryTypeChange {} -> throwSTM EntityWrongTypeException
  916 
  917 data EntityException
  918   = EntityWrongTypeException
  919   deriving (Eq, Show)
  920 
  921 instance Exception EntityException
  922 
  923 
  924 type GenericEntityChange a = GenericEntityDatatypeChange (G.Rep a)
  925 
  926 -- | Type of index of a field.
  927 -- We support up to 256 fields.
  928 type FieldIndex = Word8
  929 
  930 -- | Serialize field index.
  931 encodeFieldIndex :: FieldIndex -> B.ByteString
  932 encodeFieldIndex = B.singleton
  933 
  934 -- | Deserialize field index.
  935 decodeFieldIndex :: B.ByteString -> Maybe FieldIndex
  936 decodeFieldIndex bytes = if B.length bytes == 1 then Just $ B.head bytes else Nothing
  937 
  938 class GenericEntityDatatype f where
  939   type GenericEntityDatatypeChange f :: *
  940   processGenericEntityDatatypeChange :: f p -> B.ByteString -> B.ByteString -> Maybe (f p, GenericEntityDatatypeChange f)
  941   applyGenericEntityDatatypeChange :: (Entity a, G.Generic a, G.Rep a ~ f, EntityChange a ~ GenericEntityDatatypeChange f) => EntityVar a -> EntityChange a -> STM ()
  942 
  943 class GenericEntityConstructor f where
  944   type GenericEntityConstructorChange f :: *
  945   processGenericEntityConstructorChange :: f p -> FieldIndex -> B.ByteString -> Maybe (f p, GenericEntityConstructorChange f)
  946   applyGenericEntityConstructorChange :: f p -> GenericEntityConstructorChange f -> (B.ByteString, B.ByteString)
  947 
  948 class GenericEntitySelector f where
  949   type GenericEntitySelectorChange f :: *
  950   processGenericEntitySelectorChange :: f p -> FieldIndex -> B.ByteString -> Maybe (f p, GenericEntitySelectorChange f)
  951   applyGenericEntitySelectorChange :: f p -> FieldIndex -> GenericEntitySelectorChange f -> (B.ByteString, B.ByteString)
  952   genericEntitySelectorFieldsCount :: f p -> Word8
  953 
  954 class GenericEntityValue f where
  955   type GenericEntityValueChange f :: *
  956   processGenericEntityValueChange :: f p -> B.ByteString -> Maybe (f p, GenericEntityValueChange f)
  957   applyGenericEntityValueChange :: f p -> GenericEntityValueChange f -> B.ByteString
  958 
  959 instance GenericEntityConstructor f => GenericEntityDatatype (G.M1 G.D c f) where
  960   type GenericEntityDatatypeChange (G.M1 G.D c f) = GenericEntityConstructorChange f
  961 
  962   processGenericEntityDatatypeChange oldEntity keySuffix newValue = do -- Maybe monad
  963     fieldIndex <- decodeFieldIndex keySuffix
  964     (newEntity, change) <- processGenericEntityConstructorChange (G.unM1 oldEntity) fieldIndex newValue
  965     return (G.M1 newEntity, change)
  966 
  967   applyGenericEntityDatatypeChange var change = do
  968     entity <- readEntityVar var
  969     let (keySuffix, newValue) = applyGenericEntityConstructorChange (G.unM1 $ G.from entity) change
  970     writeEntityVarRecord var keySuffix newValue
  971 
  972   {-# INLINEABLE processGenericEntityDatatypeChange #-}
  973   {-# INLINEABLE applyGenericEntityDatatypeChange #-}
  974 
  975 instance GenericEntitySelector f => GenericEntityConstructor (G.M1 G.C c f) where
  976   type GenericEntityConstructorChange (G.M1 G.C c f) = GenericEntitySelectorChange f
  977 
  978   processGenericEntityConstructorChange oldEntity fieldIndex newValue = do -- Maybe monad
  979     (newEntity, change) <- processGenericEntitySelectorChange (G.unM1 oldEntity) fieldIndex newValue
  980     return (G.M1 newEntity, change)
  981 
  982   applyGenericEntityConstructorChange oldEntity = applyGenericEntitySelectorChange (G.unM1 oldEntity) 0
  983 
  984   {-# INLINEABLE processGenericEntityConstructorChange #-}
  985   {-# INLINEABLE applyGenericEntityConstructorChange #-}
  986 
  987 instance GenericEntityValue f => GenericEntitySelector (G.M1 G.S c f) where
  988   type GenericEntitySelectorChange (G.M1 G.S c f) = GenericEntityValueChange f
  989 
  990   -- field index must be zero here
  991   processGenericEntitySelectorChange oldEntity 0 newValue = do -- Maybe monad
  992     (newEntity, change) <- processGenericEntityValueChange (G.unM1 oldEntity) newValue
  993     return (G.M1 newEntity, change)
  994   processGenericEntitySelectorChange _oldEntity _fieldIndex _newValue = Nothing
  995 
  996   genericEntitySelectorFieldsCount _ = 1
  997 
  998   applyGenericEntitySelectorChange oldEntity fieldIndex change = (encodeFieldIndex fieldIndex, applyGenericEntityValueChange (G.unM1 oldEntity) change)
  999 
 1000   {-# INLINEABLE processGenericEntitySelectorChange #-}
 1001   {-# INLINEABLE genericEntitySelectorFieldsCount #-}
 1002   {-# INLINEABLE applyGenericEntitySelectorChange #-}
 1003 
 1004 instance (GenericEntitySelector a, GenericEntitySelector b) => GenericEntitySelector (a G.:*: b) where
 1005   type GenericEntitySelectorChange (a G.:*: b) = Either (GenericEntitySelectorChange a) (GenericEntitySelectorChange b)
 1006 
 1007   processGenericEntitySelectorChange (a G.:*: b) fieldIndex newValue = do -- Maybe monad
 1008     let aFieldCount = genericEntitySelectorFieldsCount a
 1009     if fieldIndex < aFieldCount then do
 1010       (newEntity, change) <- processGenericEntitySelectorChange a fieldIndex newValue
 1011       return (newEntity G.:*: b, Left change)
 1012     else do
 1013       (newEntity, change) <- processGenericEntitySelectorChange b (fieldIndex - aFieldCount) newValue
 1014       return (a G.:*: newEntity, Right change)
 1015 
 1016   genericEntitySelectorFieldsCount (a G.:*: b) = genericEntitySelectorFieldsCount a + genericEntitySelectorFieldsCount b
 1017 
 1018   applyGenericEntitySelectorChange (a G.:*: b) fieldIndex change = case change of
 1019     Left l -> applyGenericEntitySelectorChange a fieldIndex l
 1020     Right r -> applyGenericEntitySelectorChange b (fieldIndex + genericEntitySelectorFieldsCount a) r
 1021 
 1022   {-# INLINEABLE processGenericEntitySelectorChange #-}
 1023   {-# INLINEABLE genericEntitySelectorFieldsCount #-}
 1024   {-# INLINEABLE applyGenericEntitySelectorChange #-}
 1025 
 1026 -- value
 1027 instance BasicEntity a => GenericEntityValue (G.K1 G.R a) where
 1028   type GenericEntityValueChange (G.K1 G.R a) = EntityChange a
 1029 
 1030   processGenericEntityValueChange _oldEntity newValue = Just (G.K1 newEntity, newEntity) where
 1031     newEntity = deserializeBasicEntity newValue
 1032 
 1033   applyGenericEntityValueChange _oldEntity = serializeBasicEntity
 1034 
 1035   {-# INLINEABLE processGenericEntityValueChange #-}
 1036   {-# INLINEABLE applyGenericEntityValueChange #-}
 1037 
 1038 
 1039 -- | Handy function to generate compile-time entity id out of text.
 1040 hashTextToEntityId :: T.Text -> Q Exp
 1041 hashTextToEntityId = hashTextDecl "entityIdHash_" [t| EntityId |] $ \e -> [| EntityId (BS.toShort $e) |]
 1042 
 1043 -- | Handy function to generate compile-time entity type id out of text.
 1044 hashTextToEntityTypeId :: T.Text -> Q Exp
 1045 hashTextToEntityTypeId = hashTextDecl "entityTypeIdHash_" [t| EntityTypeId |] $ \e -> [| EntityTypeId (BS.toShort $e) |]
 1046 
 1047 -- | Handy function to generate compile-time entity interface id out of text.
 1048 hashTextToEntityInterfaceId :: T.Text -> Q Exp
 1049 hashTextToEntityInterfaceId = hashTextDecl "entityInterfaceIdHash_" [t| EntityInterfaceId |] $ \e -> [| EntityInterfaceId (BS.toShort $e) |]
 1050 
 1051 -- | Helper method for comparing interfaces' types.
 1052 -- Helps solving problems with kinds.
 1053 {-# INLINE eqEntityInterfaces #-}
 1054 eqEntityInterfaces :: (EntityInterface a, EntityInterface b) => Proxy a -> Proxy b -> Maybe ((Proxy a) :~: (Proxy b))
 1055 eqEntityInterfaces _ _ = eqT
 1056 
 1057 -- | Handy 'interfaceEntity' implementation generator.
 1058 interfaceEntityExp :: [Name] -> ExpQ
 1059 interfaceEntityExp interfaceNames = do
 1060   p <- newName "p"
 1061   let
 1062     f n q = caseE [| eqEntityInterfaces $(varE p) (Proxy :: Proxy $(conT n)) |]
 1063       [ match [p| Just Refl |] (normalB [| EntityInterfaced |]) []
 1064       , match [p| Nothing |] (normalB q) []
 1065       ]
 1066   lamE [varP p, wildP] $ foldr f (conE 'EntityNotInterfaced) interfaceNames
 1067 
 1068 -- | Typeclass for registration of complex entities.
 1069 class EntityRegistration (a :: k) where
 1070   performEntityRegistration :: EntityManager -> Proxy a -> IO ()
 1071 
 1072 -- | Register all simple instances of 'Entity' and 'EntityInterface',
 1073 -- perform registration from any 'EntityRegistration' instances in scope.
 1074 -- Type is :: EntityManager -> IO ()
 1075 -- Beware of TH declaration groups!
 1076 registerEntitiesAndInterfacesExp :: ExpQ
 1077 registerEntitiesAndInterfacesExp = do
 1078   em <- newName "entityManager"
 1079 
 1080   -- simple Entity instances
 1081   entityInstancesStmts <- do
 1082     ClassI _ decs <- reify ''Entity
 1083     (concat <$>) . forM decs $ \(InstanceD Nothing context (AppT _ t) _) ->
 1084       if null context then do
 1085         supportDefault <- isInstance ''Default [t]
 1086         if supportDefault then do
 1087           supportBasicEntity <- isInstance ''BasicEntity [t]
 1088           if supportBasicEntity then do
 1089             supportOrd <- isInstance ''Ord [t]
 1090             if supportOrd then return [noBindS [| let a = def :: $(return t) in registerBasicOrdEntityType $(varE em) (getEntityTypeId a) $ return $ SomeBasicOrdEntity a |] ]
 1091             else return [noBindS [| let a = def :: $(return t) in registerBasicEntityType $(varE em) (getEntityTypeId a) $ return $ SomeBasicEntity a |] ]
 1092           else return [noBindS [| let a = def :: $(return t) in registerEntityType $(varE em) (getEntityTypeId a) $ return $ SomeEntity a |] ]
 1093         else do
 1094           reportWarning $ shows t " doesn't have Default instance. Cannot automatically register its Entity."
 1095           return []
 1096       else return []
 1097 
 1098   -- EntityInterface instances
 1099   entityInterfaceInstancesStmts <- do
 1100     ClassI _ decs <- reify ''EntityInterface
 1101     (concat <$>) . forM decs $ \(InstanceD Nothing context (AppT _ t) _) ->
 1102       if null context then return [noBindS [| registerEntityInterface $(varE em) (getEntityInterfaceId (Proxy :: Proxy $(return t))) $ return $ SomeEntityInterface (Proxy :: Proxy $(return t)) |] ]
 1103       else return []
 1104 
 1105   -- EntityRegistration instances
 1106   entityRegistrationInstancesStmts <- do
 1107     ClassI _ decs <- reify ''EntityRegistration
 1108     (concat <$>) . forM decs $ \(InstanceD Nothing context (AppT _ t) _) ->
 1109       if null context then return [noBindS [| performEntityRegistration $(varE em) (Proxy :: Proxy $(return t)) |] ]
 1110       else do
 1111         reportError $ shows t " has non-empty context for EntityRegistration instance"
 1112         return []
 1113 
 1114   lamE [varP em] $ doE $ entityInstancesStmts ++ entityInterfaceInstancesStmts ++ entityRegistrationInstancesStmts