Internal.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module RON.Data.Internal (
    Encoding (..),
    ReducedChunk (..),
    Reducer (..),
    Reducible (..),
    Replicated (..),
    ReplicatedAsObject (..),
    ReplicatedAsPayload (..),
    Unapplied,
    WireReducer,
    advanceToObject,
    eqPayload,
    eqRef,
    evalObjectState,
    evalObjectState_,
    getObjectState,
    getObjectStateChunk,
    modifyObjectStateChunk,
    modifyObjectStateChunk_,
    newObjectFrame,
    reduceState,
    reduceObjectStates,
    stateFromWireChunk,
    stateToWireChunk,
    tryFromRon,
    tryOptionFromRon,
    wireStateChunk,
    pattern Some,
    --
    objectEncoding,
    rconcat,
    payloadEncoding,
    --
    fromRon,
    newRon,
    --
    ObjectStateT,
    MonadObjectState,
) where

import RON.Prelude

import Data.List (minimum)
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text

import RON.Error (
    Error (Error),
    MonadE,
    correct,
    errorContext,
    liftMaybe,
 )
import RON.Event (Event (..), ReplicaClock, advance, decodeEvent, timeValue)
import RON.Semilattice (BoundedSemilattice)
import RON.Types (
    Atom (AInteger, AString, AUuid),
    ObjectFrame (ObjectFrame, frame, uuid),
    ObjectRef (ObjectRef),
    Op (Op, opId, payload, refId),
    Payload,
    StateChunk (StateChunk),
    StateFrame,
    UUID (UUID),
    WireChunk,
    WireStateChunk (WireStateChunk, stateBody, stateType),
 )

-- | Reduce all chunks of specific type and object in the frame
type WireReducer = UUID -> NonEmpty WireChunk -> [WireChunk]

data Reducer = Reducer
    { wireReducer :: WireReducer
    , stateReducer :: WireStateChunk -> WireStateChunk -> WireStateChunk
    }

-- | Unapplied patches and raw ops
type Unapplied = ([ReducedChunk], [Op])

{- | Untyped-reducible types.
Untyped means if this type is a container then the types of data contained in
it is not considered.
-}
class (BoundedSemilattice a, Eq a) => Reducible a where
    -- | UUID of the type
    reducibleOpType :: UUID

    -- | Load a state from a state chunk.
    stateFromChunk :: [Op] -> a

    -- | Store a state to a state chunk
    stateToChunk :: a -> [Op]

    -- | Merge a state with patches and raw ops
    applyPatches :: a -> Unapplied -> (a, Unapplied)
    applyPatches a (patches, ops) =
        ( a
            <> foldMap ((.patchValue) . patchFromChunk) patches
            <> foldMap ((.patchValue) . patchFromRawOp) ops
        , mempty
        )

    -- | Merge patches and raw ops into bigger patches or throw obsolete ops
    reduceUnappliedPatches :: Unapplied -> Unapplied
    reduceUnappliedPatches (patches, ops) =
        ( maybeToList
            . fmap (patchToChunk @a . sconcat)
            . nonEmpty
            $ map patchFromChunk patches <> map patchFromRawOp ops
        , []
        )

stateToWireChunk :: forall rep. (Reducible rep) => rep -> WireStateChunk
stateToWireChunk rep = wireStateChunk @rep $ StateChunk $ stateToChunk @rep rep

stateFromWireChunk ::
    forall a m. (MonadE m, Reducible a) => WireStateChunk -> m a
stateFromWireChunk WireStateChunk{stateType, stateBody} = do
    unless (stateType == reducibleOpType @a) $
        throwError $
            Error
                "bad type"
                [ Error ("expected " <> show (reducibleOpType @a)) []
                , Error ("got " <> show stateType) []
                ]
    pure $ stateFromChunk stateBody

data ReducedChunk = ReducedChunk
    { rcRef :: UUID
    , rcBody :: [Op]
    }
    deriving (Show)

data Patch a = Patch {patchRef :: UUID, patchValue :: a}

instance (Semigroup a) => Semigroup (Patch a) where
    Patch ref1 a1 <> Patch ref2 a2 = Patch (min ref1 ref2) (a1 <> a2)

patchFromRawOp :: (Reducible a) => Op -> Patch a
patchFromRawOp op@Op{opId} =
    Patch{patchRef = opId, patchValue = stateFromChunk [op]}

patchFromChunk :: (Reducible a) => ReducedChunk -> Patch a
patchFromChunk ReducedChunk{rcRef, rcBody} =
    Patch{patchRef = rcRef, patchValue = stateFromChunk rcBody}

patchToChunk :: (Reducible a) => Patch a -> ReducedChunk
patchToChunk Patch{patchRef, patchValue} =
    ReducedChunk{rcRef = patchRef, rcBody = stateBody}
  where
    WireStateChunk{stateBody} = stateToWireChunk patchValue

-- | Base class for typed encoding
class Replicated a where
    {- | Instances SHOULD implement 'encoding' either as 'objectEncoding' or as
    'payloadEncoding'
    -}
    encoding :: Encoding a

data Encoding a = Encoding
    { encodingNewRon ::
        forall m.
        (MonadState StateFrame m, ReplicaClock m) =>
        a ->
        m Payload
    , encodingFromRon ::
        forall m.
        (MonadE m, MonadState StateFrame m) =>
        Payload ->
        m a
    }

-- | Encode typed data to a payload with possible addition objects
newRon ::
    (MonadState StateFrame m, ReplicaClock m, Replicated a) => a -> m Payload
newRon = encodingNewRon where Encoding{encodingNewRon} = encoding

{- | Decode typed data from a payload.
The implementation may use other objects in the frame to resolve references.
-}
fromRon :: (MonadE m, MonadState StateFrame m, Replicated a) => Payload -> m a
fromRon = encodingFromRon where Encoding{encodingFromRon} = encoding

-- | Standard implementation of 'Replicated' for 'ReplicatedAsObject' types.
objectEncoding :: (ReplicatedAsObject a) => Encoding a
objectEncoding =
    Encoding
        { encodingNewRon = \a -> do
            ObjectRef uuid <- newObject a
            pure [AUuid uuid]
        , encodingFromRon = objectFromRon $ runReaderT readObject
        }

-- | Standard implementation of 'Replicated' for 'ReplicatedAsPayload' types.
payloadEncoding :: (ReplicatedAsPayload a) => Encoding a
payloadEncoding =
    Encoding
        { encodingNewRon = pure . toPayload
        , encodingFromRon = fromPayload
        }

{- | Instances of this class are encoded as payload only.

Law: @'encoding' == 'payloadEncoding'@
-}
class (Replicated a) => ReplicatedAsPayload a where
    -- | Encode data
    toPayload :: a -> Payload

    -- | Decode data
    fromPayload :: (MonadE m) => Payload -> m a

instance Replicated Int64 where encoding = payloadEncoding

instance ReplicatedAsPayload Int64 where
    toPayload int = [AInteger int]
    fromPayload atoms = errorContext "Integer" $ case atoms of
        [AInteger int] -> pure int
        _ -> throwError "Expected Integer"

instance Replicated UUID where encoding = payloadEncoding

instance ReplicatedAsPayload UUID where
    toPayload u = [AUuid u]
    fromPayload atoms = errorContext "UUID" $ case atoms of
        [AUuid u] -> pure u
        _ -> throwError "Expected UUID"

instance Replicated Text where encoding = payloadEncoding

instance ReplicatedAsPayload Text where
    toPayload t = [AString t]
    fromPayload atoms = errorContext "String" $ case atoms of
        [AString t] -> pure t
        _ -> throwError "Expected String"

instance Replicated Char where encoding = payloadEncoding

instance ReplicatedAsPayload Char where
    toPayload c = [AString $ Text.singleton c]
    fromPayload atoms = errorContext "Char" $ case atoms of
        [AString (Text.uncons -> Just (c, ""))] -> pure c
        _ -> throwError "Expected one-character string"

{- | Instances of this class are encoded as objects.
An enclosing object's payload will be filled with this object's id.

Law: @'encoding' == 'objectEncoding'@
-}
class (Reducible (Rep a), Replicated a) => ReplicatedAsObject a where
    -- | Untyped RON-RDT representation
    type Rep a

    -- | Encode data. Write frame and return id.
    newObject ::
        (MonadState StateFrame m, ReplicaClock m) => a -> m (ObjectRef a)

    -- | Decode data
    readObject :: (MonadE m, MonadObjectState a m) => m a

objectFromRon :: (MonadE m) => (ObjectRef a -> m a) -> Payload -> m a
objectFromRon handler atoms =
    errorContext "objectFromRon" $
        case atoms of
            [AUuid uuid] -> handler $ ObjectRef uuid
            _ -> throwError "Expected object UUID"

-- | Create new 'ObjectFrame' from a value
newObjectFrame ::
    (ReplicaClock m, ReplicatedAsObject a) => a -> m (ObjectFrame a)
newObjectFrame a = do
    (ObjectRef uuid, frame) <- runStateT (newObject a) mempty
    pure ObjectFrame{uuid, frame}

getObjectStateChunk ::
    forall a m. (MonadE m, MonadObjectState a m) => m (StateChunk (Rep a))
getObjectStateChunk = do
    ObjectRef uuid <- ask
    frame <- get
    WireStateChunk{stateType, stateBody} <-
        liftMaybe "no such object in chunk" $ Map.lookup uuid frame
    unless (stateType == reducibleOpType @(Rep a)) $
        throwError $
            Error
                "bad type"
                [ Error ("expected " <> show (reducibleOpType @(Rep a))) []
                , Error ("got " <> show stateType) []
                ]
    pure $ StateChunk stateBody

modifyObjectStateChunk ::
    forall a b m.
    (MonadE m, MonadObjectState a m, ReplicaClock m) =>
    (StateChunk (Rep a) -> m (b, StateChunk (Rep a))) ->
    m b
modifyObjectStateChunk f = do
    advanceToObject
    ObjectRef uuid <- ask
    chunk <- getObjectStateChunk
    (a, StateChunk chunk') <- f chunk
    modify' $
        Map.insert
            uuid
            WireStateChunk
                { stateType = reducibleOpType @(Rep a)
                , stateBody = chunk'
                }
    pure a

modifyObjectStateChunk_ ::
    (MonadE m, MonadObjectState a m, ReplicaClock m) =>
    (StateChunk (Rep a) -> m (StateChunk (Rep a))) ->
    m ()
modifyObjectStateChunk_ f =
    modifyObjectStateChunk \chunk -> do
        chunk' <- f chunk
        pure ((), chunk')

eqRef :: ObjectRef a -> Payload -> Bool
eqRef (ObjectRef uuid) = \case
    [AUuid ref] -> uuid == ref
    _ -> False

eqPayload :: (ReplicatedAsPayload a) => a -> Payload -> Bool
eqPayload a = (toPayload a ==)

pattern ATrue :: Atom
pattern ATrue = AUuid (UUID 0xe36e69000000000 0) -- true

pattern AFalse :: Atom
pattern AFalse = AUuid (UUID 0xaa5c37a40000000 0) -- false

instance Replicated Bool where encoding = payloadEncoding

instance ReplicatedAsPayload Bool where
    toPayload b
        | b = [ATrue]
        | otherwise = [AFalse]

    fromPayload =
        errorContext "Bool" . \case
            [ATrue] -> pure True
            [AFalse] -> pure False
            _ -> throwError "Expected single UUID `true` or `false`"

type ObjectStateT b m a = ReaderT (ObjectRef b) (StateT StateFrame m) a

type MonadObjectState a m =
    (MonadReader (ObjectRef a) m, MonadState StateFrame m, Reducible (Rep a))

advanceToObject :: (MonadE m, MonadObjectState a m, ReplicaClock m) => m ()
advanceToObject = do
    allObjectTimes <- getAllObjectTimes
    for_ (maximumMay allObjectTimes) advance
  where
    getAllObjectTimes =
        map (\Event{time} -> timeValue time) . mapMaybe decodeEvent
            <$> getAllObjectUuids

    getAllObjectUuids = do
        ObjectRef objectId <- ask
        StateChunk chunk <- getObjectStateChunk
        pure $ objectId : foldMap allOpUuids chunk

    allOpUuids Op{opId, refId, payload} =
        opId : refId : [u | AUuid u <- payload]

reduceState ::
    forall rep.
    (Reducible rep) =>
    StateChunk rep ->
    StateChunk rep ->
    StateChunk rep
reduceState (StateChunk s1) (StateChunk s2) =
    StateChunk $ stateToChunk @rep $ stateFromChunk s1 <> stateFromChunk s2

reduceObjectStates ::
    forall a m.
    (MonadE m, MonadState StateFrame m, ReplicatedAsObject a) =>
    NonEmpty (ObjectRef a) ->
    m (ObjectRef a)
reduceObjectStates (obj :| objs) = do
    c :| cs <- for (obj :| objs) $ runReaderT getObjectStateChunk
    let chunk = foldl' (reduceState @(Rep a)) c cs
        oid = minimum [i | ObjectRef i <- obj : objs]
    modify' $ Map.insert oid $ wireStateChunk chunk
    pure $ ObjectRef oid

rconcat ::
    forall a m.
    (MonadE m, MonadState StateFrame m, ReplicatedAsObject a) =>
    NonEmpty UUID ->
    m a
rconcat uuids =
    errorContext "rconcat" do
        ObjectRef ref <- reduceObjectStates @a $ ObjectRef <$> uuids
        fromRon [AUuid ref]

tryFromRon ::
    (MonadE m, MonadState StateFrame m, Replicated a) =>
    Payload ->
    m (Maybe a)
tryFromRon = correct Nothing . fmap Just . fromRon

tryOptionFromRon ::
    (MonadE m, MonadState StateFrame m, Replicated a) =>
    Payload ->
    m (Maybe a)
tryOptionFromRon payload = case payload of
    Some : payload' ->
        correct Nothing $
            (Just <$> fromRon payload)
                `catchError` \e1 ->
                    (Just <$> fromRon payload')
                        `catchError` \e2 ->
                            throwError $ Error "tryOptionFromRon" [e1, e2]
    _ -> tryFromRon payload

{- | TODO(2019-08-06, cblp) Remove a year after release
(the release is planned on 2019-08; removal is planned on 2020-08)
-}
pattern Some :: Atom
pattern Some = AUuid (UUID 0xdf3c69000000000 0)
{-# DEPRECATED Some "Will be removed soon" #-}

getObjectState :: (MonadE m, MonadObjectState a m) => m (Rep a)
getObjectState = do
    StateChunk chunk <- getObjectStateChunk
    pure $ stateFromChunk chunk

wireStateChunk ::
    forall rep. (Reducible rep) => StateChunk rep -> WireStateChunk
wireStateChunk (StateChunk stateBody) =
    WireStateChunk{stateType = reducibleOpType @rep, stateBody}

-- | Run ObjectFrame action
evalObjectState :: (Monad m) => ObjectFrame b -> ObjectStateT b m a -> m a
evalObjectState ObjectFrame{uuid, frame} action =
    evalStateT (runReaderT action $ ObjectRef uuid) frame

-- | Run ObjectFrame action, starting with an empty frame
evalObjectState_ :: (Monad m) => StateT StateFrame m a -> m a
evalObjectState_ action = evalStateT action mempty

instance Replicated (ObjectRef a) where
    encoding = payloadEncoding

instance ReplicatedAsPayload (ObjectRef a) where
    toPayload (ObjectRef uuid) = toPayload uuid
    fromPayload = fmap ObjectRef . fromPayload