{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-|
Module      : Knit.Effect.Serialize
Description : Effect for serializing and deserializing data
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

This module provides the types and supporting functions to use various serializers
with the caching framework in knit-haskell.
A <https://hackage.haskell.org/package/cereal Cereal> implementation is
provided, but using a different implementation is straightforward.
See <https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample2.hs CacheExample2>
for an example.

The cache framework expects an explicit dictionary (i.e., record-of-functions)
rather than a Typeclass for serialization. 
Since various serializers use slightly different Typeclass structures and function names,
we can't write code which is polynorphic in the serialization type-class. But with an 
explicit dictionary we get that flexibility.  Once a dictionary for encoding and decoding
objects of arbitrary type is provided, along with the typeclass constraint required to use it,
the code in this module can convert that into all the functions the caching effect
requires to cache that data type or streams of it.

This could be implemented as a more straightforward effect but at the cost of complicating
the use for streams.  Making the explicit dictionary available balances the flexibility of
being able to change serializers with the relative ease of bootstrapping the single item serializer
into a serializer for streams, etc.
-}
module Knit.Effect.Serialize
  (
    -- * Types
    SerializeDict(..)
  , Serialize(..)
  , SerializeEnv

    -- * Deploy Implementations
  , serializeOne
  , serializeStreamlyViaList

    -- * Implementations
  , DefaultCacheData
  , DefaultSerializer
  , cerealStreamlyDict

    -- * Reader for Serializer Dictionary
  , getSerializeDict
  , runSerializeEnv

    -- * Errors
  , SerializationError(..)
  )
where

import qualified Polysemy                      as P
import qualified Polysemy.Error                as P
import qualified Polysemy.Reader               as PR
import           Data.Int (Int64)
import qualified Data.Serialize                as S
import qualified Data.Text                     as T
import qualified Data.Word                     as Word

import qualified Streamly                      as Streamly
import qualified Streamly.Prelude              as Streamly
import qualified Streamly.Data.Fold                 as Streamly.Fold
import qualified Streamly.Memory.Array         as Streamly.Array
import qualified Streamly.Internal.Data.Array           as Streamly.Data.Array
import qualified Streamly.External.Cereal      as Streamly.Cereal

-- | Error Type for Serialization errors.  Simplifies catching and reporting them.
data SerializationError = SerializationError T.Text deriving (Int -> SerializationError -> ShowS
[SerializationError] -> ShowS
SerializationError -> String
(Int -> SerializationError -> ShowS)
-> (SerializationError -> String)
-> ([SerializationError] -> ShowS)
-> Show SerializationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SerializationError] -> ShowS
$cshowList :: [SerializationError] -> ShowS
show :: SerializationError -> String
$cshow :: SerializationError -> String
showsPrec :: Int -> SerializationError -> ShowS
$cshowsPrec :: Int -> SerializationError -> ShowS
Show)


{- |
Encoding/decoding functions for Serializing data, made explicit
here so we can pass them around as part of a configuration.
Allows for different Serializers as well as
Serializing to different types of in-memory store.

NB: The first parameter is of kind @Type -> Constraint@, e.g., @S.Serialize@,
which must be satisfied by anything serializable by
the implementation.

This should be straightforward to write for any serializer, and is all that's required to use
a non-default serializer as long as it serializes to @ByteStream@
(or, less likely, @Streamly.Memory.Array.Array@)
-}
data SerializeDict c ct =
  SerializeDict
  { SerializeDict c ct -> forall a. c a => a -> ct
encodeOne :: forall a. c a => a -> ct
  , SerializeDict c ct
-> forall a. c a => ct -> Either SerializationError a
decodeOne :: forall a. c a => ct -> Either SerializationError a
  , SerializeDict c ct -> ct -> Int64
encBytes :: ct -> Int64
  }

-- | Make the dictionary available within effect stacks
type SerializeEnv c ct = PR.Reader (SerializeDict c ct)

-- | access the dictionary
getSerializeDict :: P.Member (SerializeEnv c ct) r => P.Sem r (SerializeDict c ct)
getSerializeDict :: Sem r (SerializeDict c ct)
getSerializeDict = Sem r (SerializeDict c ct)
forall i (r :: [Effect]). MemberWithError (Reader i) r => Sem r i
PR.ask
{-# INLINEABLE getSerializeDict #-}

-- | run the SerializeEnv effect by giving it the dictionary for use by the cache functions
runSerializeEnv :: SerializeDict c ct -> P.InterpreterFor (SerializeEnv c ct) r
runSerializeEnv :: SerializeDict c ct -> InterpreterFor (SerializeEnv c ct) r
runSerializeEnv = SerializeDict c ct -> Sem (SerializeEnv c ct : r) a -> Sem r a
forall i (r :: [Effect]) a. i -> Sem (Reader i : r) a -> Sem r a
PR.runReader
{-# INLINEABLE runSerializeEnv #-}

{- |
Record-of-functions type to carry encoding/decoding functions for Serializing data.
Allows for different Serializers as well as
Serializing to different types of in memory store.
@encode@ returns the encoded value *and* a (possibly buffered) copy of its input. 
This is designed around serialization of streams, where the original (effectful) stream may be expensive to run. But once run,
we can return a "buffered" stream which just unfolds from a memory buffer.
In many cases, we will just return the input in that slot.
-}
data Serialize e r a ct where
  Serialize :: (P.MemberWithError (P.Error e) r)
            => (a -> P.Sem r (ct, a)) -- ^ Encode
            -> (ct -> P.Sem r a)      -- ^ Decode
            -> (ct -> Int64)          -- ^ Size (in Bytes)
            -> Serialize e r a ct

-- | Given a @'SerializeDict' c ct@ and @a@ satisfying @c a@,
-- produce the (trivial) 'Serialize' record-of-functions to encode/decode a single @a@.
serializeOne :: (c a, P.MemberWithError (P.Error SerializationError) r)
             => SerializeDict c ct
             -> Serialize SerializationError r a ct
serializeOne :: SerializeDict c ct -> Serialize SerializationError r a ct
serializeOne (SerializeDict encOne :: forall a. c a => a -> ct
encOne decOne :: forall a. c a => ct -> Either SerializationError a
decOne bytes :: ct -> Int64
bytes) =
  let enc :: a -> Sem r (ct, a)
enc a :: a
a = (ct, a) -> Sem r (ct, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ct
forall a. c a => a -> ct
encOne a
a, a
a)
      {-# INLINEABLE enc #-}      
      dec :: ct -> Sem r a
dec = forall (r :: [Effect]) a.
Member (Error SerializationError) r =>
Either SerializationError a -> Sem r a
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
P.fromEither @SerializationError (Either SerializationError a -> Sem r a)
-> (ct -> Either SerializationError a) -> ct -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ct -> Either SerializationError a
forall a. c a => ct -> Either SerializationError a
decOne
      {-# INLINEABLE dec #-}
  in (a -> Sem r (ct, a))
-> (ct -> Sem r a)
-> (ct -> Int64)
-> Serialize SerializationError r a ct
forall e (r :: [Effect]) a ct.
MemberWithError (Error e) r =>
(a -> Sem r (ct, a))
-> (ct -> Sem r a) -> (ct -> Int64) -> Serialize e r a ct
Serialize a -> Sem r (ct, a)
enc ct -> Sem r a
dec ct -> Int64
bytes
{-# INLINEABLE serializeOne #-}

-- | Given a @'SerializeDict' c ct@ and @a@ satisfying @c [a]@--usually
-- true as long as @a@ satisfies @c a@--produce
-- the 'Serialize' record-of-functions to encode/decode @Streamly.SerialT (P.Sem r) a@,
-- by mapping the stream to a (lazy) list, and encoding that and
-- decoding as a list and creating the stream from that.
serializeStreamlyViaList ::
  (P.MemberWithError (P.Error SerializationError) r, P.Member (P.Embed IO) r, c [a])
  => SerializeDict c ct
  -> Serialize SerializationError r (Streamly.SerialT (P.Sem r) a) ct 
serializeStreamlyViaList :: SerializeDict c ct
-> Serialize SerializationError r (SerialT (Sem r) a) ct
serializeStreamlyViaList (SerializeDict encOne :: forall a. c a => a -> ct
encOne decOne :: forall a. c a => ct -> Either SerializationError a
decOne bytes :: ct -> Int64
bytes) =
  let enc :: SerialT (Sem r) a -> Sem r (ct, SerialT (Sem r) a)
enc = Fold (Sem r) a (ct, SerialT (Sem r) a)
-> SerialT (Sem r) a -> Sem r (ct, SerialT (Sem r) a)
forall (m :: * -> *) a b.
Monad m =>
Fold m a b -> SerialT m a -> m b
Streamly.fold (Fold (Sem r) a ct
-> Fold (Sem r) a (SerialT (Sem r) a)
-> Fold (Sem r) a (ct, SerialT (Sem r) a)
forall (m :: * -> *) a b c.
Monad m =>
Fold m a b -> Fold m a c -> Fold m a (b, c)
Streamly.Fold.tee
                           (([a] -> ct) -> Fold (Sem r) a [a] -> Fold (Sem r) a ct
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> ct
forall a. c a => a -> ct
encOne (Fold (Sem r) a [a] -> Fold (Sem r) a ct)
-> Fold (Sem r) a [a] -> Fold (Sem r) a ct
forall a b. (a -> b) -> a -> b
$ Fold (Sem r) a [a]
forall (m :: * -> *) a. Monad m => Fold m a [a]
Streamly.Fold.toList) 
                           ((Array a -> SerialT (Sem r) a)
-> Fold (Sem r) a (Array a) -> Fold (Sem r) a (SerialT (Sem r) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Array a -> SerialT (Sem r) a
forall (m :: * -> *) (t :: Effect) a.
(Monad m, IsStream t) =>
Array a -> t m a
Streamly.Data.Array.toStream) Fold (Sem r) a (Array a)
forall (m :: * -> *) a. MonadIO m => Fold m a (Array a)
Streamly.Data.Array.write)
                          )
      {-# INLINEABLE enc #-}
      dec :: ct -> Sem r (SerialT (Sem r) a)
dec = Either SerializationError (SerialT (Sem r) a)
-> Sem r (SerialT (Sem r) a)
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
P.fromEither (Either SerializationError (SerialT (Sem r) a)
 -> Sem r (SerialT (Sem r) a))
-> (ct -> Either SerializationError (SerialT (Sem r) a))
-> ct
-> Sem r (SerialT (Sem r) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> SerialT (Sem r) a)
-> Either SerializationError [a]
-> Either SerializationError (SerialT (Sem r) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> SerialT (Sem r) a
forall (m :: * -> *) (t :: Effect) a.
(Monad m, IsStream t) =>
[a] -> t m a
Streamly.fromList (Either SerializationError [a]
 -> Either SerializationError (SerialT (Sem r) a))
-> (ct -> Either SerializationError [a])
-> ct
-> Either SerializationError (SerialT (Sem r) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ct -> Either SerializationError [a]
forall a. c a => ct -> Either SerializationError a
decOne
      {-# INLINEABLE dec #-}
  in (SerialT (Sem r) a -> Sem r (ct, SerialT (Sem r) a))
-> (ct -> Sem r (SerialT (Sem r) a))
-> (ct -> Int64)
-> Serialize SerializationError r (SerialT (Sem r) a) ct
forall e (r :: [Effect]) a ct.
MemberWithError (Error e) r =>
(a -> Sem r (ct, a))
-> (ct -> Sem r a) -> (ct -> Int64) -> Serialize e r a ct
Serialize SerialT (Sem r) a -> Sem r (ct, SerialT (Sem r) a)
enc ct -> Sem r (SerialT (Sem r) a)
dec ct -> Int64
bytes
{-# INLINEABLE serializeStreamlyViaList #-}


-- | type-alias for default in-memory storage type.
type DefaultCacheData = Streamly.Array.Array Word.Word8

-- | type-alias for default Serializer
type DefaultSerializer = S.Serialize

-- | Implementation of `SerializeDict` for the cereal serializer,
-- encoding to/decoding from `Streamly.Memory.Array.Array`
cerealStreamlyDict :: SerializeDict DefaultSerializer DefaultCacheData
cerealStreamlyDict :: SerializeDict DefaultSerializer DefaultCacheData
cerealStreamlyDict =
  (forall a. DefaultSerializer a => a -> DefaultCacheData)
-> (forall a.
    DefaultSerializer a =>
    DefaultCacheData -> Either SerializationError a)
-> (DefaultCacheData -> Int64)
-> SerializeDict DefaultSerializer DefaultCacheData
forall (c :: * -> Constraint) ct.
(forall a. c a => a -> ct)
-> (forall a. c a => ct -> Either SerializationError a)
-> (ct -> Int64)
-> SerializeDict c ct
SerializeDict
  forall a. DefaultSerializer a => a -> DefaultCacheData
Streamly.Cereal.encodeStreamlyArray
  ((Text -> SerializationError)
-> Either Text a -> Either SerializationError a
forall a b c. (a -> b) -> Either a c -> Either b c
mapLeft Text -> SerializationError
SerializationError (Either Text a -> Either SerializationError a)
-> (DefaultCacheData -> Either Text a)
-> DefaultCacheData
-> Either SerializationError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  DefaultCacheData -> Either Text a
forall a. Serialize a => DefaultCacheData -> Either Text a
Streamly.Cereal.decodeStreamlyArray)
  (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64)
-> (DefaultCacheData -> Int) -> DefaultCacheData -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultCacheData -> Int
forall a. Storable a => Array a -> Int
Streamly.Array.length)
{-# INLINEABLE cerealStreamlyDict #-}

-- | Map the left side of an Either
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft :: (a -> b) -> Either a c -> Either b c
mapLeft f :: a -> b
f = (a -> Either b c) -> (c -> Either b c) -> Either a c -> Either b c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (b -> Either b c
forall a b. a -> Either a b
Left (b -> Either b c) -> (a -> b) -> a -> Either b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) c -> Either b c
forall a b. b -> Either a b
Right
{-# INLINEABLE mapLeft #-}