-- Copyright 2023 Google LLC
--
-- Use of this source code is governed by a BSD-style
-- license that can be found in the LICENSE file or at
-- https://developers.google.com/open-source/licenses/bsd

{-# LANGUAGE UndecidableInstances #-}

module Actor (
  ActorM, Actor (..), launchActor, send, selfMailbox, messageLoop,
  sliceMailbox, SubscribeMsg (..), IncServer, IncServerT, FileWatcher,
  StateServer, flushDiffs, handleSubscribeMsg, subscribe, subscribeIO, sendSync,
  runIncServerT, launchFileWatcher, Mailbox,
  ) where

import Control.Concurrent
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.IORef
import Data.Text (Text)
import System.Directory (getModificationTime)
import GHC.Generics

import IncState
import MonadUtil
import Util (readFileText)

-- === Actor implementation ===

newtype ActorM msg a = ActorM { runActorM ::  ReaderT (Chan msg) IO a }
  deriving (Functor, Applicative, Monad, MonadIO)

newtype Mailbox a = Mailbox { sendToMailbox :: a -> IO () }

class (MonadIO m) => Actor msg m | m -> msg where
  selfChan :: m (Chan msg)

instance Actor msg (ActorM msg) where
  selfChan = ActorM ask

instance Actor msg m => Actor msg (ReaderT r m) where selfChan = lift $ selfChan
instance Actor msg m => Actor msg (StateT  s m) where selfChan = lift $ selfChan

send :: MonadIO m => Mailbox msg -> msg -> m ()
send chan msg = liftIO $ sendToMailbox chan msg

selfMailbox :: Actor msg m => (a -> msg) -> m (Mailbox a)
selfMailbox asSelfMessage = do
  chan <- selfChan
  return $ Mailbox \msg -> writeChan chan (asSelfMessage msg)

launchActor :: MonadIO m => ActorM msg () -> m (Mailbox msg)
launchActor m = liftIO do
  chan <- newChan
  void $ forkIO $ runReaderT (runActorM m) chan
  return $ Mailbox \msg -> writeChan chan msg

messageLoop :: Actor msg m => (msg -> m ()) -> m ()
messageLoop handleMessage = do
  forever do
    msg <- liftIO . readChan =<< selfChan
    handleMessage msg

sliceMailbox :: (b -> a) -> Mailbox a -> Mailbox b
sliceMailbox f (Mailbox sendMsg) = Mailbox $ sendMsg . f

-- === Promises ===

newtype Promise a = Promise (MVar a)
newtype PromiseSetter a = PromiseSetter (MVar a)

newPromise :: MonadIO m => m (Promise a, PromiseSetter a)
newPromise = do
  v <- liftIO $ newEmptyMVar
  return (Promise v, PromiseSetter v)

waitForPromise :: MonadIO m => Promise a -> m a
waitForPromise (Promise v) = liftIO $ readMVar v

setPromise :: MonadIO m => PromiseSetter a -> a -> m ()
setPromise (PromiseSetter v) x = liftIO $ putMVar v x

-- Message that expects a synchronous reponse
data SyncMsg msg response = SyncMsg msg (PromiseSetter response)

sendSync :: MonadIO m => Mailbox (SyncMsg msg response) -> msg -> m response
sendSync mailbox msg = do
  (result, resultSetter) <- newPromise
  send mailbox (SyncMsg msg resultSetter)
  waitForPromise result


-- === Diff server ===

data IncServerState s = IncServerState
  { subscribers     :: [Mailbox (Delta s)]
  , bufferedUpdates :: Delta s
  , curIncState     :: s }
  deriving (Generic)

class (IncState s, MonadIO m) => IncServer s m | m -> s where
  getIncServerStateRef :: m (IORef (IncServerState s))

data SubscribeMsg s = Subscribe (SyncMsg (Mailbox (Delta s)) s)  deriving (Show)

getIncServerState :: IncServer s m => m (IncServerState s)
getIncServerState = readRef =<< getIncServerStateRef

updateIncServerState :: IncServer s m => (IncServerState s -> IncServerState s) -> m ()
updateIncServerState f = do
  ref <- getIncServerStateRef
  prev <- readRef ref
  writeRef ref $ f prev

handleSubscribeMsg :: IncServer s m => SubscribeMsg s -> m ()
handleSubscribeMsg (Subscribe (SyncMsg newSub response)) = do
  flushDiffs
  updateIncServerState \s -> s { subscribers = newSub : subscribers s }
  curState <- curIncState <$> getIncServerState
  setPromise response curState

flushDiffs :: IncServer s m => m ()
flushDiffs = do
  d <- bufferedUpdates <$> getIncServerState
  updateIncServerState \s -> s { bufferedUpdates = mempty }
  subs <- subscribers <$> getIncServerState
  -- TODO: consider testing for emptiness here
  forM_ subs \sub -> send sub d

type StateServer s = Mailbox (SubscribeMsg s)

subscribe :: (IncState s, Actor msg m) => (Delta s -> msg) -> StateServer s -> m s
subscribe inject server = do
  updateChannel <- selfMailbox inject
  sendSync (sliceMailbox Subscribe server) updateChannel

subscribeIO :: IncState s => StateServer s -> IO (s, Chan (Delta s))
subscribeIO server = do
  chan <- newChan
  let mailbox = Mailbox (writeChan chan)
  s <- sendSync (sliceMailbox Subscribe server) mailbox
  return (s, chan)

newtype IncServerT s m a = IncServerT { runIncServerT' :: ReaderT (Ref (IncServerState s)) m a }
  deriving (Functor, Applicative, Monad, MonadIO, Actor msg, FreshNames name, MonadTrans)

instance (MonadIO m, IncState s) => IncServer s (IncServerT s m) where
  getIncServerStateRef = IncServerT ask

instance (MonadIO m, IncState s, d ~ Delta s) => DefuncState d (IncServerT s m) where
  update d = updateIncServerState \s -> s
    { bufferedUpdates = bufferedUpdates s <> d
    , curIncState     = curIncState     s `applyDiff` d}

instance (MonadIO m, IncState s) => LabelReader (SingletonLabel s) (IncServerT s m) where
  getl It = curIncState <$> getIncServerState

runIncServerT :: (MonadIO m, IncState s) => s -> IncServerT s m a -> m a
runIncServerT s cont = do
  ref <- newRef $ IncServerState [] mempty s
  runReaderT (runIncServerT' cont) ref

-- === Refs ===
-- Just a wrapper around IORef lifted to `MonadIO`

type Ref = IORef

newRef :: MonadIO m => a -> m (Ref a)
newRef = liftIO . newIORef

readRef :: MonadIO m => Ref a -> m a
readRef = liftIO . readIORef

writeRef :: MonadIO m => Ref a -> a -> m ()
writeRef ref val = liftIO $ writeIORef ref val

-- === Clock ===

-- Provides a periodic clock signal. The time interval is in microseconds.
launchClock :: MonadIO m => Int -> Mailbox () -> m ()
launchClock intervalMicroseconds mailbox =
  liftIO $ void $ forkIO $ forever do
    threadDelay intervalMicroseconds
    send mailbox ()

-- === File watcher ===

type SourceFileContents = Text
type FileWatcher = StateServer (Overwritable SourceFileContents)

data FileWatcherMsg =
   ClockSignal_FW ()
 | Subscribe_FW (SubscribeMsg (Overwritable Text))
   deriving (Show)

launchFileWatcher :: MonadIO m => FilePath -> m FileWatcher
launchFileWatcher path = sliceMailbox Subscribe_FW <$> launchActor (fileWatcherImpl path)

fileWatcherImpl :: FilePath -> ActorM FileWatcherMsg ()
fileWatcherImpl path = do
  initContents <- readFileText path
  t0 <- liftIO $ getModificationTime path
  launchClock 100000 =<< selfMailbox ClockSignal_FW
  modTimeRef <- newRef t0
  runIncServerT (Overwritable initContents) $ messageLoop \case
    Subscribe_FW msg -> handleSubscribeMsg msg
    ClockSignal_FW () -> do
      tOld <- readRef modTimeRef
      tNew <- liftIO $ getModificationTime path
      when (tNew /= tOld) do
        newContents <- readFileText path
        update $ OverwriteWith newContents
        flushDiffs
        writeRef modTimeRef tNew

-- === instances ===

instance Show msg => Show (SyncMsg msg response) where
  show (SyncMsg msg _) = show msg

instance Show (Mailbox a) where
  show _ = "mailbox"

deriving instance Actor msg m => Actor msg (FreshNameT m)