{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

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 qualified Data.LVar as LVar
import Data.Some
import Ema.Asset (Asset (AssetGenerated), Format (Html))
import Ema.CLI (Cli)
import qualified Ema.CLI as CLI
import Ema.Class (Ema)
import qualified Ema.Generate as Generate
import qualified Ema.Server 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 Action -> LByteString) -> IO ()
runEmaPure Some Action -> LByteString
render = do
  IO (Either () (DSum Action Identity)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either () (DSum Action Identity)) -> IO ())
-> IO (Either () (DSum Action Identity)) -> IO ()
forall a b. (a -> b) -> a -> b
$
    (Some Action -> () -> () -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar () -> m ())
-> IO (Either () (DSum Action Identity))
forall model route b.
(Ema model route, Show route) =>
(Some Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
runEma (\Some 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 Action -> LByteString
render Some Action
act) ((forall (m :: * -> *).
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
  Some Action -> LVar () -> m ())
 -> IO (Either () (DSum Action Identity)))
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar () -> m ())
-> IO (Either () (DSum Action Identity))
forall a b. (a -> b) -> a -> b
$ \Some Action
act LVar ()
model -> do
      LVar () -> () -> m ()
forall (m :: * -> *) a. MonadIO m => LVar a -> a -> m ()
LVar.set LVar ()
model ()
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Some Action -> Bool
CLI.isLiveServer Some Action
act) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: * -> *) 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 Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
runEma Some Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar model -> m b
runModel = do
  Cli
cli <- IO Cli
CLI.cliAction
  Cli
-> (Some Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
forall model route b.
(Ema model route, Show route) =>
Cli
-> (Some Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
runEmaWithCli Cli
cli Some Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some 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 Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Some Action -> LVar model -> m b)
-> IO (Either b (DSum Action Identity))
runEmaWithCli Cli
cli Some Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar model -> m b
runModel = do
  LVar model
model <- IO (LVar model)
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory
    Text -> LoggingT IO ()
forall (m :: * -> *). 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 :: * -> *). MonadLogger m => Text -> m ()
logInfoN Text
"Waiting for initial model ..."
  IO b
-> IO (DSum Action Identity)
-> IO (Either b (DSum 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 :: * -> *) 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 Action -> LVar model -> LoggingT IO b
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some Action -> LVar model -> m b
runModel (Cli -> Some Action
CLI.action Cli
cli) LVar model
model)
    ((LoggingT IO (DSum Action Identity)
 -> Logger -> IO (DSum Action Identity))
-> Logger
-> LoggingT IO (DSum Action Identity)
-> IO (DSum Action Identity)
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO (DSum Action Identity)
-> Logger -> IO (DSum Action Identity)
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO (DSum Action Identity) -> IO (DSum Action Identity))
-> LoggingT IO (DSum Action Identity) -> IO (DSum Action Identity)
forall a b. (a -> b) -> a -> b
$ Some Action
-> LVar model
-> (Some Action -> model -> route -> Asset LByteString)
-> LoggingT IO (DSum Action Identity)
forall model route (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
 Show route) =>
Some Action
-> LVar model
-> (Some Action -> model -> route -> Asset LByteString)
-> m (DSum Action Identity)
runEmaWithCliInCwd (Cli -> Some Action
CLI.action Cli
cli) LVar model
model Some 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 Action
-> LVar model
-> (Some Action -> model -> route -> Asset LByteString)
-> m (DSum Action Identity)
runEmaWithCliInCwd Some Action
cliAction LVar model
model Some Action -> model -> route -> Asset LByteString
render = do
  model
val <- LVar model -> m model
forall (m :: * -> *) a. MonadIO m => LVar a -> m a
LVar.get LVar model
model
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN Text
"... initial model is now available."
  case Some Action
cliAction of
    Some (CLI.Generate FilePath
dest) -> do
      [FilePath]
fs <-
        m [FilePath] -> m [FilePath]
forall (f :: * -> *) 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 :: * -> *).
(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 Action -> model -> route -> Asset LByteString
render Some Action
cliAction)
      DSum Action Identity -> m (DSum Action Identity)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DSum Action Identity -> m (DSum Action Identity))
-> DSum Action Identity -> m (DSum Action Identity)
forall a b. (a -> b) -> a -> b
$ FilePath -> Action [FilePath]
CLI.Generate FilePath
dest Action [FilePath] -> Identity [FilePath] -> DSum Action Identity
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum 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 :: * -> *).
(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 Action -> model -> route -> Asset LByteString
render Some Action
cliAction)
      DSum Action Identity -> m (DSum Action Identity)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DSum Action Identity -> m (DSum Action Identity))
-> DSum Action Identity -> m (DSum Action Identity)
forall a b. (a -> b) -> a -> b
$ (Host, Port) -> Action ()
CLI.Run (Host
host, Port
port) Action () -> Identity () -> DSum Action Identity
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum 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 :: * -> *). 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 :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
f
        f a -> f () -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Handle -> BufferMode -> f ()
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdout BufferMode
LineBuffering f () -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> f ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout)