{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Static.Serialise where
import qualified Codec.Serialise as SR
import qualified Data.Binary as BN
import qualified Data.ByteString.Lazy as LBS
import Codec.Serialise (Serialise)
import Data.Binary (Binary)
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.Kind (Type)
import Data.Singletons (Sing)
import Data.Singletons.TH (genDefunSymbols)
import GHC.Generics (Generic)
import Type.Reflection ((:~~:) (..), TypeRep, Typeable,
eqTypeRep, typeRep)
data SKeyedExt g = SKeyedExt !String !g
deriving (Read, Show, Generic, Binary, Serialise, Eq, Ord, Functor)
data SKeyedError =
SKeyedNotFound String
| SKeyedExtDecodeFailure String
deriving (Read, Show, Generic, Binary, Serialise, Eq, Ord)
class RepVal g (v :: Type) (k :: kt) where
toRep :: Sing k -> v -> g
fromRep :: Sing k -> g -> Either String v
genDefunSymbols [''RepVal]
castOrFail :: forall s t . (Typeable s, Typeable t) => s -> Either String t
castOrFail s = case reps `eqTypeRep` rept of
Just HRefl -> Right s
Nothing ->
Left
$ "fromTypeable: type-mismatch, expecting: "
<> show rept
<> "; actual: "
<> show reps
where
rept = typeRep :: TypeRep t
reps = typeRep :: TypeRep s
instance Typeable v => RepVal Dynamic v k where
toRep _ = toDyn
fromRep _ s = case fromDynamic s of
Nothing -> Left "fromDynamic failed; type-mismatch"
Just v -> Right v
data DoubleEncoding s b where
Decoded :: (Typeable t, s t) => !t -> DoubleEncoding s b
HalfEncoded :: !b -> DoubleEncoding s b
type DSerialise = DoubleEncoding Serialise LBS.ByteString
instance Serialise DSerialise where
encode (Decoded t) = SR.encode
(HalfEncoded (SR.serialise t) :: DoubleEncoding Serialise LBS.ByteString)
encode (HalfEncoded t) = SR.encode t
decode = HalfEncoded <$> SR.decode
instance (Typeable v, Serialise v) => RepVal DSerialise v k where
toRep _ = Decoded
fromRep _ (Decoded v) = castOrFail v
fromRep _ (HalfEncoded s) = case SR.deserialiseOrFail s of
Left e -> Left (show e)
Right v -> Right v
instance Eq DSerialise where
a == b = SR.serialise a == SR.serialise b
instance Ord DSerialise where
compare a b = compare (SR.serialise a) (SR.serialise b)
type DBinary = DoubleEncoding Binary LBS.ByteString
decodeFullyOrFail :: Binary a => LBS.ByteString -> Either String a
decodeFullyOrFail s = case BN.decodeOrFail s of
Left e -> Left ("Data.Binary decode failure: " <> show e)
Right (bs, o, v) -> if LBS.null bs
then Right v
else Left ("Data.Binary decode leftovers: " <> show (bs, o))
instance Binary DBinary where
put (Decoded t) =
BN.put (HalfEncoded (BN.encode t) :: DoubleEncoding Binary LBS.ByteString)
put (HalfEncoded t) = BN.put t
get = HalfEncoded <$> BN.get
instance (Typeable v, Binary v) => RepVal DBinary v k where
toRep _ = Decoded
fromRep _ (Decoded v) = castOrFail v
fromRep _ (HalfEncoded s) = decodeFullyOrFail s
instance Eq DBinary where
a == b = BN.encode a == BN.encode b
instance Ord DBinary where
compare a b = compare (BN.encode a) (BN.encode b)