module Database.Perdure.CDeserializer (
cDeser,
deserializeFromArray,
deserializeFromFullArray,
unsafeSeqDeserializer,
Deserializer(..),
Deserializable(..),
DeserOut(..),
module Database.Perdure.Persistent,
module Database.Perdure.CRef
) where
import Prelude ()
import Cgm.Prelude
import Database.Perdure.Persistent
import Database.Perdure.StoreFile
import Database.Perdure.CRef
import Cgm.Data.Word
import Data.Bits
deserializeFromArray :: (Allocation f, Allocation df, Deserializable w) => Deserializer df a -> ArrayRange (PrimArray f w) -> DeserOut a
deserializeFromArray d = (\(ArrayRange ar start _) -> deserialize d (refineLen start) ar) . deserInput
deserializeFromFullArray :: forall f df w a. (Allocation f, Allocation df, Deserializable w, LgMultiple w Bool, Prim w) =>
Deserializer df a -> ArrayRange (PrimArray f w) -> a
deserializeFromFullArray d ar = case deserializeFromArray d ar of
DeserOut a end -> bool (error $ "Inconsistent deserialized size: " ++ show (end, refineLen $ arrayLen ar :: Len Bool Word)) a $
(coarsenLen end :: Len w Word) == arrayLen ar
unsafeSeqDeserializer :: Persister a -> Deserializer Free a
unsafeSeqDeserializer p =
cDeser p (DeserializerContext (error "seqDeserializer has no file" :: ReplicatedFile) (error "seqDeserializer has no cache"))
cDeser :: Persister a -> DeserializerContext -> Deserializer Free a
cDeser p = case p of
PartialWordPersister n -> const $ partialWordDeserializer n
PairPersister pa pb -> liftA2 (liftA2 (,)) (cDeser pa) (cDeser pb)
EitherPersister pa pb -> \dc -> cDeser persister dc >>= bool (Left <$> cDeser pa dc) (Right <$> cDeser pb dc)
ViewPersister i pb -> flip functorIacomap i . cDeser pb
SummationPersister pi' d _ -> \dc -> cDeser pi' dc >>= d (\pb ba -> fmap ba $ cDeser pb dc)
DRefPersister' -> \dc -> DRef persister dc <$> cDeser persister dc
CRefPersister' _ pra -> fmap Refed . cDeser pra
instance InjectionACofunctor (Deserializer f) where
iacomap = functorIacomap
bitDeserializer :: Deserializer f Word
bitDeserializer = Deserializer $ \b ar -> DeserOut (let (wIx, bIx) = coarseRem b in (indexArray ar wIx `partialShiftRL` getLen bIx) .&. 1) (b + 1)
partialWordDeserializer :: Len Bool Word -> Deserializer f Word
partialWordDeserializer n
| n == 0 = pure 0
| n == 1 = bitDeserializer
| otherwise =
Deserializer $ \b ar ->
DeserOut (
let (wIx, bIx) = coarseRem b
avail = wordBits bIx
overflow = n avail
n' = wordBits n
in bool (indexArray ar wIx `partialShiftL` getLen (n' bIx) `partialShiftRL` getLen n')
((indexArray ar wIx `partialShiftRL` getLen bIx) +
(indexArray ar (wIx + 1) `partialShiftL` getLen (wordBits overflow) `partialShiftRL` getLen n')) $
(signed $* getLen overflow) > 0)
(b + n)
class Deserializable a where deserInput :: (Allocation f, Allocation f') => ArrayRange (PrimArray f a) -> ArrayRange (PrimArray f' Word)
instance Deserializable Word where deserInput = primArrayMatchAllocation
instance Deserializable Word32 where
deserInput a = onWordConv
(primArrayMatchAllocation $ retract wordConvArrayRange a)
(fullArrayRange $ mkArrayWith (coarsenLen $ arrayLen a) $
(\i -> retract wordConv $ retract splitWord64LE
(indexArray a i, if i + 1 < arrayLen a then indexArray a (i + 1) else 0)) . refineLen)
instance Deserializable Word64 where
deserInput a = onWordConv
(fullArrayRange $ mkArrayWith (refineLen $ arrayLen a) $
(\(i, r) -> retract wordConv $ bool fst snd (r == 0) $ apply splitWord64LE $ indexArray a i) . coarseRem)
(primArrayMatchAllocation $ retract wordConvArrayRange a)
data DeserOut a = DeserOut {
deserValue :: !a,
deserPos :: !(Len Bool Word)} deriving Functor
newtype Deserializer f a = Deserializer {deserialize :: Len Bool Word -> PrimArray f Word -> DeserOut a}
instance Functor (Deserializer f) where
fmap g = Deserializer . ((fmap g <$>) <$>) . deserialize
instance Applicative (Deserializer f) where
pure x = Deserializer $ \b _ -> DeserOut x b
g <*> x = Deserializer $ \b ptr -> case deserialize g b ptr of DeserOut g' b' -> deserialize (g' <$> x) b' ptr
instance Monad (Deserializer f) where
return = pure
(>>=) = fmap join' . flip fmap where
join' :: Deserializer f (Deserializer f a) -> Deserializer f a
join' d2 = Deserializer $ \b ptr -> case deserialize d2 b ptr of DeserOut d b' -> deserialize d b' ptr