module Ema.App
  ( runEma,
    runEmaPure,
    runEmaWithCli,
  )
where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import Control.Monad.Logger (MonadLoggerIO, logInfoN)
import Control.Monad.Logger.Extras
  ( colorize,
    logToStdout,
    runLoggerLoggingT,
  )
import Data.Dependent.Sum (DSum ((:=>)))
import Data.LVar (LVar)
import Data.LVar qualified as LVar
import Data.Some
import Ema.Asset (Asset (AssetGenerated), Format (Html))
import Ema.CLI (Cli)
import Ema.CLI qualified as CLI
import Ema.Class (Ema)
import Ema.Generate qualified as Generate
import Ema.Server qualified as Server
import System.Directory (getCurrentDirectory)
import UnliftIO
  ( BufferMode (BlockBuffering, LineBuffering),
    MonadUnliftIO,
    hFlush,
    hSetBuffering,
  )

-- | Pure version of @runEmaWith@ (i.e with no model).
--
-- Due to purity, there is no impure state, and thus no time-varying model.
-- Neither is there a concept of route, as only a single route (index.html) is
-- expected, whose HTML contents is specified as the only argument to this
-- function.
runEmaPure ::
  -- | How to render a route
  (Some CLI.Action -> LByteString) ->
  IO ()
runEmaPure :: (Some @Type Action -> LByteString) -> IO ()
runEmaPure Some @Type Action -> LByteString
render = do
  IO (Either () (DSum @Type Action Identity)) -> IO ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (IO (Either () (DSum @Type Action Identity)) -> IO ())
-> IO (Either () (DSum @Type Action Identity)) -> IO ()
forall a b. (a -> b) -> a -> b
$
    (Some @Type Action -> () -> () -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar () -> m ())
-> IO (Either () (DSum @Type Action Identity))
forall model route b.
(Ema model route, Show route) =>
(Some @Type Action -> model -> route -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar model -> m b)
-> IO (Either b (DSum @Type Action Identity))
runEma (\Some @Type Action
act () () -> Format -> LByteString -> Asset LByteString
forall a. Format -> a -> Asset a
AssetGenerated Format
Html (LByteString -> Asset LByteString)
-> LByteString -> Asset LByteString
forall a b. (a -> b) -> a -> b
$ Some @Type Action -> LByteString
render Some @Type Action
act) ((forall (m :: Type -> Type).
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
  Some @Type Action -> LVar () -> m ())
 -> IO (Either () (DSum @Type Action Identity)))
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar () -> m ())
-> IO (Either () (DSum @Type Action Identity))
forall a b. (a -> b) -> a -> b
$ \Some @Type Action
act LVar ()
model -> do
      LVar () -> () -> m ()
forall (m :: Type -> Type) a. MonadIO m => LVar a -> a -> m ()
LVar.set LVar ()
model ()
      Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Some @Type Action -> Bool
CLI.isLiveServer Some @Type Action
act) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound

-- | Convenient version of @runEmaWith@ that takes initial model and an update
-- function. You typically want to use this.
--
-- It uses @race_@ to properly clean up the update action when the ema thread
-- exits, and vice-versa.
runEma ::
  forall model route b.
  (Ema model route, Show route) =>
  -- | How to render a route, given the model
  (Some CLI.Action -> model -> route -> Asset LByteString) ->
  -- | A long-running IO action that will update the @model@ @LVar@ over time.
  -- This IO action must set the initial model value in the very beginning.
  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => Some CLI.Action -> LVar model -> m b) ->
  IO (Either b (DSum CLI.Action Identity))
runEma :: (Some @Type Action -> model -> route -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar model -> m b)
-> IO (Either b (DSum @Type Action Identity))
runEma Some @Type Action -> model -> route -> Asset LByteString
render forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> LVar model -> m b
runModel = do
  Cli
cli <- IO Cli
CLI.cliAction
  Cli
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar model -> m b)
-> IO (Either b (DSum @Type Action Identity))
forall model route b.
(Ema model route, Show route) =>
Cli
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar model -> m b)
-> IO (Either b (DSum @Type Action Identity))
runEmaWithCli Cli
cli Some @Type Action -> model -> route -> Asset LByteString
render forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> LVar model -> m b
runModel

-- | Like @runEma@ but takes the CLI action
--
-- Useful if you are handling CLI arguments yourself.
runEmaWithCli ::
  forall model route b.
  (Ema model route, Show route) =>
  Cli ->
  -- | How to render a route, given the model
  (Some CLI.Action -> model -> route -> Asset LByteString) ->
  -- | A long-running IO action that will update the @model@ @LVar@ over time.
  -- This IO action must set the initial model value in the very beginning.
  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => Some CLI.Action -> LVar model -> m b) ->
  IO (Either b (DSum CLI.Action Identity))
runEmaWithCli :: Cli
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> (forall (m :: Type -> Type).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some @Type Action -> LVar model -> m b)
-> IO (Either b (DSum @Type Action Identity))
runEmaWithCli Cli
cli Some @Type Action -> model -> route -> Asset LByteString
render forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> LVar model -> m b
runModel = do
  LVar model
model <- IO (LVar model)
forall (m :: Type -> Type) a. MonadIO m => m (LVar a)
LVar.empty
  -- TODO: Allow library users to control logging levels, or colors.
  let logger :: Logger
logger = Logger -> Logger
colorize Logger
logToStdout
  (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: Type -> Type) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
cwd <- IO FilePath -> LoggingT IO FilePath
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory
    Text -> LoggingT IO ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN (Text -> LoggingT IO ()) -> Text -> LoggingT IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Launching Ema under: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
cwd
    Text -> LoggingT IO ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN Text
"Waiting for initial model ..."
  IO b
-> IO (DSum @Type Action Identity)
-> IO (Either b (DSum @Type Action Identity))
forall a b. IO a -> IO b -> IO (Either a b)
race
    ((LoggingT IO b -> Logger -> IO b)
-> Logger -> LoggingT IO b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO b -> Logger -> IO b
forall (m :: Type -> Type) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO b -> IO b) -> LoggingT IO b -> IO b
forall a b. (a -> b) -> a -> b
$ Some @Type Action -> LVar model -> LoggingT IO b
forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action -> LVar model -> m b
runModel (Cli -> Some @Type Action
CLI.action Cli
cli) LVar model
model)
    ((LoggingT IO (DSum @Type Action Identity)
 -> Logger -> IO (DSum @Type Action Identity))
-> Logger
-> LoggingT IO (DSum @Type Action Identity)
-> IO (DSum @Type Action Identity)
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO (DSum @Type Action Identity)
-> Logger -> IO (DSum @Type Action Identity)
forall (m :: Type -> Type) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO (DSum @Type Action Identity)
 -> IO (DSum @Type Action Identity))
-> LoggingT IO (DSum @Type Action Identity)
-> IO (DSum @Type Action Identity)
forall a b. (a -> b) -> a -> b
$ Some @Type Action
-> LVar model
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> LoggingT IO (DSum @Type Action Identity)
forall model route (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
 Show route) =>
Some @Type Action
-> LVar model
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> m (DSum @Type Action Identity)
runEmaWithCliInCwd (Cli -> Some @Type Action
CLI.action Cli
cli) LVar model
model Some @Type Action -> model -> route -> Asset LByteString
render)

-- | Run Ema live dev server
runEmaWithCliInCwd ::
  forall model route m.
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>
  -- | CLI arguments
  Some CLI.Action ->
  -- | Your site model type, as a @LVar@ in order to support modifications over
  -- time (for hot-reload).
  --
  -- Use @Data.LVar.new@ to create it, and then -- over time -- @Data.LVar.set@
  -- or @Data.LVar.modify@ to modify it. Ema will automatically hot-reload your
  -- site as this model data changes.
  LVar model ->
  -- | Your site render function. Takes the current @model@ value, and the page
  -- @route@ type as arguments. It must return the raw HTML to render to browser
  -- or generate on disk.
  (Some CLI.Action -> model -> route -> Asset LByteString) ->
  m (DSum CLI.Action Identity)
runEmaWithCliInCwd :: Some @Type Action
-> LVar model
-> (Some @Type Action -> model -> route -> Asset LByteString)
-> m (DSum @Type Action Identity)
runEmaWithCliInCwd Some @Type Action
cliAction LVar model
model Some @Type Action -> model -> route -> Asset LByteString
render = do
  model
val <- LVar model -> m model
forall (m :: Type -> Type) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
  Text -> m ()
forall (m :: Type -> Type). MonadLogger m => Text -> m ()
logInfoN Text
"... initial model is now available."
  case Some @Type Action
cliAction of
    Some (CLI.Generate FilePath
dest) -> do
      [FilePath]
fs <-
        m [FilePath] -> m [FilePath]
forall {f :: Type -> Type} {a}. MonadIO f => f a -> f a
withBlockBuffering (m [FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$
          FilePath
-> model -> (model -> route -> Asset LByteString) -> m [FilePath]
forall model route (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
 HasCallStack) =>
FilePath
-> model -> (model -> route -> Asset LByteString) -> m [FilePath]
Generate.generate FilePath
dest model
val (Some @Type Action -> model -> route -> Asset LByteString
render Some @Type Action
cliAction)
      DSum @Type Action Identity -> m (DSum @Type Action Identity)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DSum @Type Action Identity -> m (DSum @Type Action Identity))
-> DSum @Type Action Identity -> m (DSum @Type Action Identity)
forall a b. (a -> b) -> a -> b
$ FilePath -> Action [FilePath]
CLI.Generate FilePath
dest Action [FilePath]
-> Identity [FilePath] -> DSum @Type Action Identity
forall {k} (tag :: k -> Type) (f :: k -> Type) (a :: k).
tag a -> f a -> DSum @k tag f
:=> [FilePath] -> Identity [FilePath]
forall a. a -> Identity a
Identity [FilePath]
fs
    Some (CLI.Run (Host
host, Port
port)) -> do
      Host
-> Port
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
forall model route (m :: Type -> Type).
(Ema model route, Show route, MonadIO m, MonadUnliftIO m,
 MonadLoggerIO m) =>
Host
-> Port
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
Server.runServerWithWebSocketHotReload Host
host Port
port LVar model
model (Some @Type Action -> model -> route -> Asset LByteString
render Some @Type Action
cliAction)
      DSum @Type Action Identity -> m (DSum @Type Action Identity)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DSum @Type Action Identity -> m (DSum @Type Action Identity))
-> DSum @Type Action Identity -> m (DSum @Type Action Identity)
forall a b. (a -> b) -> a -> b
$ (Host, Port) -> Action ()
CLI.Run (Host
host, Port
port) Action () -> Identity () -> DSum @Type Action Identity
forall {k} (tag :: k -> Type) (f :: k -> Type) (a :: k).
tag a -> f a -> DSum @k tag f
:=> () -> Identity ()
forall a. a -> Identity a
Identity ()
  where
    -- Temporarily use block buffering before calling an IO action that is
    -- known ahead to log rapidly, so as to not hamper serial processing speed.
    withBlockBuffering :: f a -> f a
withBlockBuffering f a
f =
      Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout (Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing)
        f () -> f a -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> f a
f
        f a -> f () -> f a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* (Handle -> BufferMode -> f ()
forall (m :: Type -> Type).
MonadIO m =>
Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering f () -> f () -> f ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Handle -> f ()
forall (m :: Type -> Type). MonadIO m => Handle -> m ()
hFlush Handle
stdout)