-- |Interpreters for 'Scratch'
module Ribosome.Interpreter.Scratch where

import Conc (interpretAtomic)
import qualified Data.Map.Strict as Map
import Exon (exon)

import Ribosome.Data.PluginName (PluginName)
import Ribosome.Data.ScratchId (ScratchId (ScratchId))
import Ribosome.Data.ScratchState (ScratchState)
import Ribosome.Effect.Scratch (Scratch (Delete, Find, Get, Show, Update))
import qualified Ribosome.Host.Data.RpcError as RpcError
import Ribosome.Host.Data.RpcError (RpcError)
import Ribosome.Host.Effect.Rpc (Rpc)
import Ribosome.Internal.Scratch (killScratch, lookupScratch, setScratchContent, showInScratch)

-- |Interpret 'Scratch' by storing the Neovim UI handles in 'AtomicState'.
-- This uses 'Resumable', see [Errors]("Ribosome#g:errors").
interpretScratchAtomic ::
  Members [Rpc !! RpcError, AtomicState (Map ScratchId ScratchState), Reader PluginName, Log, Resource] r =>
  InterpreterFor (Scratch !! RpcError) r
interpretScratchAtomic :: forall (r :: EffectRow).
Members
  '[Rpc !! RpcError, AtomicState (Map ScratchId ScratchState),
    Reader PluginName, Log, Resource]
  r =>
InterpreterFor (Scratch !! RpcError) r
interpretScratchAtomic =
  (forall x (r0 :: EffectRow).
 Scratch (Sem r0) x -> Sem (Stop RpcError : r) x)
-> InterpreterFor (Scratch !! RpcError) r
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
FirstOrder eff "interpretResumable" =>
(forall x (r0 :: EffectRow).
 eff (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumable \case
    Show t Text
text ScratchOptions
options ->
      Sem (Rpc : Stop RpcError : r) ScratchState
-> Sem (Stop RpcError : r) ScratchState
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop (t Text
-> ScratchOptions -> Sem (Rpc : Stop RpcError : r) ScratchState
forall (t :: * -> *) (r :: EffectRow).
(Foldable t,
 Members
   '[Rpc !! RpcError, Rpc, AtomicState (Map ScratchId ScratchState),
     Reader PluginName, Log, Resource]
   r) =>
t Text -> ScratchOptions -> Sem r ScratchState
showInScratch t Text
text ScratchOptions
options)
    Update ScratchId
i t Text
text -> do
      ScratchState
s <- RpcError
-> Maybe ScratchState -> Sem (Stop RpcError : r) ScratchState
forall err (r :: EffectRow) a.
Member (Stop err) r =>
err -> Maybe a -> Sem r a
stopNote (Text -> RpcError
RpcError.Unexpected [exon|No scratch buffer named '#{coerce i}' exists|]) (Maybe ScratchState -> Sem (Stop RpcError : r) ScratchState)
-> Sem (Stop RpcError : r) (Maybe ScratchState)
-> Sem (Stop RpcError : r) ScratchState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScratchId -> Sem (Stop RpcError : r) (Maybe ScratchState)
forall (r :: EffectRow).
Member (AtomicState (Map ScratchId ScratchState)) r =>
ScratchId -> Sem r (Maybe ScratchState)
lookupScratch ScratchId
i
      ScratchState
s ScratchState
-> Sem (Stop RpcError : r) ()
-> Sem (Stop RpcError : r) ScratchState
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
Members '[Resumable err eff, Stop err] r =>
InterpreterFor eff r
restop @_ @Rpc (ScratchState -> t Text -> Sem (Rpc : Stop RpcError : r) ()
forall (t :: * -> *) (r :: EffectRow).
(Foldable t, Members '[Rpc !! RpcError, Rpc] r) =>
ScratchState -> t Text -> Sem r ()
setScratchContent ScratchState
s t Text
text)
    Delete ScratchId
i ->
      (ScratchState -> Sem (Stop RpcError : r) ())
-> Maybe ScratchState -> Sem (Stop RpcError : r) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ScratchState -> Sem (Stop RpcError : r) ()
forall (r :: EffectRow).
Members
  '[Rpc !! RpcError, AtomicState (Map ScratchId ScratchState), Log]
  r =>
ScratchState -> Sem r ()
killScratch (Maybe ScratchState -> Sem (Stop RpcError : r) ())
-> Sem (Stop RpcError : r) (Maybe ScratchState)
-> Sem (Stop RpcError : r) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScratchId -> Sem (Stop RpcError : r) (Maybe ScratchState)
forall (r :: EffectRow).
Member (AtomicState (Map ScratchId ScratchState)) r =>
ScratchId -> Sem r (Maybe ScratchState)
lookupScratch ScratchId
i
    Scratch (Sem r0) x
Get ->
      (Map ScratchId ScratchState -> [ScratchState])
-> Sem (Stop RpcError : r) [ScratchState]
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets Map ScratchId ScratchState -> [ScratchState]
forall k a. Map k a -> [a]
Map.elems
    Find ScratchId
i ->
      (Map ScratchId ScratchState -> Maybe ScratchState)
-> Sem (Stop RpcError : r) (Maybe ScratchState)
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets (ScratchId -> Map ScratchId ScratchState -> Maybe ScratchState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScratchId
i)

-- |Interpret 'Scratch' by storing the Neovim UI handles in 'AtomicState'.
-- This uses 'Resumable', see [Errors]("Ribosome#g:errors").
interpretScratch ::
  Members [Rpc !! RpcError, Reader PluginName, Log, Resource, Embed IO] r =>
  InterpreterFor (Scratch !! RpcError) r
interpretScratch :: forall (r :: EffectRow).
Members
  '[Rpc !! RpcError, Reader PluginName, Log, Resource, Embed IO] r =>
InterpreterFor (Scratch !! RpcError) r
interpretScratch =
  Map ScratchId ScratchState
-> InterpreterFor (AtomicState (Map ScratchId ScratchState)) r
forall a (r :: EffectRow).
Member (Embed IO) r =>
a -> InterpreterFor (AtomicState a) r
interpretAtomic Map ScratchId ScratchState
forall a. Monoid a => a
mempty (Sem (AtomicState (Map ScratchId ScratchState) : r) a -> Sem r a)
-> (Sem ((Scratch !! RpcError) : r) a
    -> Sem (AtomicState (Map ScratchId ScratchState) : r) a)
-> Sem ((Scratch !! RpcError) : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  ((Scratch !! RpcError)
     : AtomicState (Map ScratchId ScratchState) : r)
  a
-> Sem (AtomicState (Map ScratchId ScratchState) : r) a
forall (r :: EffectRow).
Members
  '[Rpc !! RpcError, AtomicState (Map ScratchId ScratchState),
    Reader PluginName, Log, Resource]
  r =>
InterpreterFor (Scratch !! RpcError) r
interpretScratchAtomic (Sem
   ((Scratch !! RpcError)
      : AtomicState (Map ScratchId ScratchState) : r)
   a
 -> Sem (AtomicState (Map ScratchId ScratchState) : r) a)
-> (Sem ((Scratch !! RpcError) : r) a
    -> Sem
         ((Scratch !! RpcError)
            : AtomicState (Map ScratchId ScratchState) : r)
         a)
-> Sem ((Scratch !! RpcError) : r) a
-> Sem (AtomicState (Map ScratchId ScratchState) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem ((Scratch !! RpcError) : r) a
-> Sem
     ((Scratch !! RpcError)
        : AtomicState (Map ScratchId ScratchState) : r)
     a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder