{-# LANGUAGE StandaloneDeriving, DerivingVia, TypeApplications, TypeSynonymInstances, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--Serialise instances for ProjectM36.Base data types- orphan instance city
module ProjectM36.Serialise.Base where
import Codec.Winery hiding (Schema)
import Codec.Winery.Internal
import Control.Monad
import ProjectM36.Base
import ProjectM36.MerkleHash
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.TupleSet
import Data.UUID
import Data.Proxy
import Data.Word
import ProjectM36.Attribute as A
import qualified Data.Vector as V
import Data.Time.Calendar (Day,toGregorian,fromGregorian)
#if MIN_VERSION_winery(1,4,0)
#else
import qualified Data.List.NonEmpty as NE
#endif

deriving via WineryVariant Atom instance Serialise Atom
deriving via WineryVariant AtomType instance Serialise AtomType
deriving via WineryVariant Attribute instance Serialise Attribute
deriving via WineryVariant RelationTuple instance Serialise RelationTuple
deriving via WineryVariant RelationCardinality instance Serialise RelationCardinality
deriving via WineryVariant (RelationalExprBase a) instance Serialise a => Serialise (RelationalExprBase a)
deriving via WineryVariant (WithNameExprBase a) instance Serialise a => Serialise (WithNameExprBase a)
deriving via WineryVariant Notification instance Serialise Notification
deriving via WineryVariant TypeConstructorDef instance Serialise TypeConstructorDef
deriving via WineryVariant (TypeConstructorBase a) instance Serialise a => Serialise (TypeConstructorBase a)
deriving via WineryVariant DataConstructorDef instance Serialise DataConstructorDef
deriving via WineryVariant DataConstructorDefArg instance Serialise DataConstructorDefArg
deriving via WineryVariant GraphRefTransactionMarker instance Serialise GraphRefTransactionMarker
deriving via WineryVariant SchemaIsomorph instance Serialise SchemaIsomorph
deriving via WineryVariant InclusionDependency instance Serialise InclusionDependency
deriving via WineryVariant (DatabaseContextExprBase a) instance Serialise a => Serialise (DatabaseContextExprBase a)
deriving via WineryVariant (DatabaseContextIOExprBase a) instance Serialise a => Serialise (DatabaseContextIOExprBase a)
deriving via WineryVariant (RestrictionPredicateExprBase a) instance Serialise a => Serialise (RestrictionPredicateExprBase a)
deriving via WineryVariant TransactionInfo instance Serialise TransactionInfo
deriving via WineryVariant (AtomExprBase a) instance Serialise a => Serialise (AtomExprBase a)
deriving via WineryVariant MerkleHash instance Serialise MerkleHash
deriving via WineryVariant (AttributeExprBase a) instance Serialise a => Serialise (AttributeExprBase a)
deriving via WineryVariant (TupleExprsBase a) instance Serialise a => Serialise (TupleExprsBase a)
deriving via WineryVariant (TupleExprBase a) instance Serialise a => Serialise (TupleExprBase a)
deriving via WineryVariant (AttributeNamesBase a) instance Serialise a => Serialise (AttributeNamesBase a)
deriving via WineryVariant (ExtendTupleExprBase a) instance Serialise a => Serialise (ExtendTupleExprBase a)
deriving via WineryVariant Schema instance Serialise Schema
deriving via WineryVariant MergeStrategy instance Serialise MergeStrategy

fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId
fromWordsTup :: (Word32, Word32, Word32, Word32) -> TransactionId
fromWordsTup (Word32
a,Word32
b,Word32
c,Word32
d) = Word32 -> Word32 -> Word32 -> Word32 -> TransactionId
fromWords Word32
a Word32
b Word32
c Word32
d

instance Serialise TransactionId where
  schemaGen :: Proxy TransactionId -> SchemaGen Schema
schemaGen Proxy TransactionId
_ = Proxy (Word32, Word32, Word32, Word32) -> SchemaGen Schema
forall (proxy :: * -> *) a.
Serialise a =>
proxy a -> SchemaGen Schema
getSchema (Proxy (Word32, Word32, Word32, Word32)
forall k (t :: k). Proxy t
Proxy @(Word32, Word32, Word32, Word32))
  toBuilder :: TransactionId -> Builder
toBuilder TransactionId
uuid = (Word32, Word32, Word32, Word32) -> Builder
forall a. Serialise a => a -> Builder
toBuilder (TransactionId -> (Word32, Word32, Word32, Word32)
toWords TransactionId
uuid)
  extractor :: Extractor TransactionId
extractor = (Word32, Word32, Word32, Word32) -> TransactionId
fromWordsTup ((Word32, Word32, Word32, Word32) -> TransactionId)
-> Extractor (Word32, Word32, Word32, Word32)
-> Extractor TransactionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor (Word32, Word32, Word32, Word32)
forall a. Serialise a => Extractor a
extractor
  decodeCurrent :: Decoder TransactionId
decodeCurrent = (Word32, Word32, Word32, Word32) -> TransactionId
fromWordsTup ((Word32, Word32, Word32, Word32) -> TransactionId)
-> Decoder (Word32, Word32, Word32, Word32)
-> Decoder TransactionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Word32, Word32, Word32, Word32)
forall a. Serialise a => Decoder a
decodeCurrent

#if MIN_VERSION_winery(1,4,0)
#else
instance Serialise a => Serialise (NE.NonEmpty a) where
  schemaGen _ = SVector <$> getSchema (Proxy @a)
  toBuilder xs = varInt (length xs) <> foldMap toBuilder xs
  extractor = NE.fromList . V.toList <$> extractListBy extractor --use nonempty instead to replace error with winery error
  decodeCurrent = do
    n <- decodeVarInt
    l <- replicateM n decodeCurrent
    pure (NE.fromList l)
#endif

fromGregorianTup :: (Integer, Int, Int) -> Day
fromGregorianTup :: (Integer, Int, Int) -> Day
fromGregorianTup (Integer
a, Int
b, Int
c) = Integer -> Int -> Int -> Day
fromGregorian Integer
a Int
b Int
c

instance Serialise Day where
  schemaGen :: Proxy Day -> SchemaGen Schema
schemaGen Proxy Day
_ = Proxy (Integer, Int, Int) -> SchemaGen Schema
forall (proxy :: * -> *) a.
Serialise a =>
proxy a -> SchemaGen Schema
getSchema (Proxy (Integer, Int, Int)
forall k (t :: k). Proxy t
Proxy @(Integer, Int, Int))
  toBuilder :: Day -> Builder
toBuilder Day
day = (Integer, Int, Int) -> Builder
forall a. Serialise a => a -> Builder
toBuilder (Day -> (Integer, Int, Int)
toGregorian Day
day)
  extractor :: Extractor Day
extractor = (Integer, Int, Int) -> Day
fromGregorianTup ((Integer, Int, Int) -> Day)
-> Extractor (Integer, Int, Int) -> Extractor Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor (Integer, Int, Int)
forall a. Serialise a => Extractor a
extractor
  decodeCurrent :: Decoder Day
decodeCurrent = (Integer, Int, Int) -> Day
fromGregorianTup ((Integer, Int, Int) -> Day)
-> Decoder (Integer, Int, Int) -> Decoder Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (Integer, Int, Int)
forall a. Serialise a => Decoder a
decodeCurrent

instance Serialise Attributes where
  schemaGen :: Proxy Attributes -> SchemaGen Schema
schemaGen Proxy Attributes
_ = Schema -> Schema
forall a. SchemaP a -> SchemaP a
SVector (Schema -> Schema) -> SchemaGen Schema -> SchemaGen Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy Attribute -> SchemaGen Schema
forall (proxy :: * -> *) a.
Serialise a =>
proxy a -> SchemaGen Schema
getSchema (Proxy Attribute
forall k (t :: k). Proxy t
Proxy @Attribute)
  toBuilder :: Attributes -> Builder
toBuilder Attributes
attrs = Int -> Builder
forall a. (Bits a, Integral a) => a -> Builder
varInt (Vector Attribute -> Int
forall a. Vector a -> Int
V.length (Attributes -> Vector Attribute
attributesVec Attributes
attrs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Attribute -> Builder) -> [Attribute] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Attribute -> Builder
forall a. Serialise a => a -> Builder
toBuilder (Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Attributes -> Vector Attribute
attributesVec Attributes
attrs))
  extractor :: Extractor Attributes
extractor =
    [Attribute] -> Attributes
attributesFromList ([Attribute] -> Attributes)
-> (Vector Attribute -> [Attribute])
-> Vector Attribute
-> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Vector Attribute -> Attributes)
-> Extractor (Vector Attribute) -> Extractor Attributes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor Attribute -> Extractor (Vector Attribute)
forall a. Typeable a => Extractor a -> Extractor (Vector a)
extractListBy Extractor Attribute
forall a. Serialise a => Extractor a
extractor

  decodeCurrent :: Decoder Attributes
decodeCurrent = do
    Int
n <- Decoder Int
forall a. (Num a, Bits a) => Decoder a
decodeVarInt
    [Attribute]
l <- Int -> Decoder Attribute -> Decoder [Attribute]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Decoder Attribute
forall a. Serialise a => Decoder a
decodeCurrent
    Attributes -> Decoder Attributes
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Attribute] -> Attributes
A.attributesFromList [Attribute]
l)

-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple.
instance Serialise Relation where
  schemaGen :: Proxy Relation -> SchemaGen Schema
schemaGen Proxy Relation
_ = Proxy (Attributes, [Vector Atom]) -> SchemaGen Schema
forall (proxy :: * -> *) a.
Serialise a =>
proxy a -> SchemaGen Schema
getSchema (Proxy (Attributes, [Vector Atom])
forall k (t :: k). Proxy t
Proxy @(Attributes, [V.Vector Atom]))
  toBuilder :: Relation -> Builder
toBuilder Relation
rel = (Attributes, [Vector Atom]) -> Builder
forall a. Serialise a => a -> Builder
toBuilder (Relation -> Attributes
attributes Relation
rel, (RelationTuple -> Vector Atom) -> [RelationTuple] -> [Vector Atom]
forall a b. (a -> b) -> [a] -> [b]
map RelationTuple -> Vector Atom
tupleAtoms (Relation -> [RelationTuple]
tuplesList Relation
rel))
  extractor :: Extractor Relation
extractor = (Attributes, [Vector Atom]) -> Relation
makeRelation ((Attributes, [Vector Atom]) -> Relation)
-> Extractor (Attributes, [Vector Atom]) -> Extractor Relation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor (Attributes, [Vector Atom])
forall a. Serialise a => Extractor a
extractor
   where
    makeRelation :: (Attributes, [Vector Atom]) -> Relation
makeRelation (Attributes
attrs, [Vector Atom]
atomList) =  Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet ((Vector Atom -> RelationTuple) -> [Vector Atom] -> [RelationTuple]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attrs) [Vector Atom]
atomList))
  decodeCurrent :: Decoder Relation
decodeCurrent = do
    (Attributes
attrs, [Vector Atom]
atomList) <- Decoder (Attributes, [Vector Atom])
forall a. Serialise a => Decoder a
decodeCurrent
    Relation -> Decoder Relation
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attributes -> RelationTupleSet -> Relation
Relation Attributes
attrs ([RelationTuple] -> RelationTupleSet
RelationTupleSet ((Vector Atom -> RelationTuple) -> [Vector Atom] -> [RelationTuple]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attrs) [Vector Atom]
atomList)))   

type SlimTupleSet = Either () (Attributes, [V.Vector Atom])

slimTupleSet :: RelationTupleSet -> SlimTupleSet
slimTupleSet :: RelationTupleSet -> SlimTupleSet
slimTupleSet RelationTupleSet
tupSet =
  case RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet of
    [] -> () -> SlimTupleSet
forall a b. a -> Either a b
Left ()
    RelationTuple
tup:[RelationTuple]
tups -> (Attributes, [Vector Atom]) -> SlimTupleSet
forall a b. b -> Either a b
Right (RelationTuple -> Attributes
tupleAttributes RelationTuple
tup, (RelationTuple -> Vector Atom) -> [RelationTuple] -> [Vector Atom]
forall a b. (a -> b) -> [a] -> [b]
map RelationTuple -> Vector Atom
tupleAtoms (RelationTuple
tupRelationTuple -> [RelationTuple] -> [RelationTuple]
forall a. a -> [a] -> [a]
:[RelationTuple]
tups))

-- | restore slimmed tuple set to include single shared attributes list
fattenTupleSet :: SlimTupleSet -> RelationTupleSet
fattenTupleSet :: SlimTupleSet -> RelationTupleSet
fattenTupleSet Left{} = RelationTupleSet
emptyTupleSet
fattenTupleSet (Right (Attributes
attrs, [Vector Atom]
vtups)) = [RelationTuple] -> RelationTupleSet
RelationTupleSet ([RelationTuple] -> RelationTupleSet)
-> [RelationTuple] -> RelationTupleSet
forall a b. (a -> b) -> a -> b
$ (Vector Atom -> RelationTuple) -> [Vector Atom] -> [RelationTuple]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Vector Atom -> RelationTuple
RelationTuple Attributes
attrs) [Vector Atom]
vtups

-- | A special instance of Serialise which cuts down on duplicate attributes- we should only serialise the attributes at the top-level and not duplicate them per tuple. If we have an empty tupleset, we lack all attributes which is fine in this case.
instance Serialise RelationTupleSet where
  schemaGen :: Proxy RelationTupleSet -> SchemaGen Schema
schemaGen Proxy RelationTupleSet
_ = Proxy SlimTupleSet -> SchemaGen Schema
forall (proxy :: * -> *) a.
Serialise a =>
proxy a -> SchemaGen Schema
getSchema (Proxy SlimTupleSet
forall k (t :: k). Proxy t
Proxy @SlimTupleSet)
  toBuilder :: RelationTupleSet -> Builder
toBuilder RelationTupleSet
tupSet = SlimTupleSet -> Builder
forall a. Serialise a => a -> Builder
toBuilder (RelationTupleSet -> SlimTupleSet
slimTupleSet RelationTupleSet
tupSet)
  extractor :: Extractor RelationTupleSet
extractor = SlimTupleSet -> RelationTupleSet
fattenTupleSet (SlimTupleSet -> RelationTupleSet)
-> Extractor SlimTupleSet -> Extractor RelationTupleSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Extractor SlimTupleSet
forall a. Serialise a => Extractor a
extractor
  decodeCurrent :: Decoder RelationTupleSet
decodeCurrent = SlimTupleSet -> RelationTupleSet
fattenTupleSet (SlimTupleSet -> RelationTupleSet)
-> Decoder SlimTupleSet -> Decoder RelationTupleSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder SlimTupleSet
forall a. Serialise a => Decoder a
decodeCurrent