{-# 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,
)
runEmaPure ::
(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
runEma ::
forall model route b.
(Ema model route, Show route) =>
(Some CLI.Action -> model -> route -> Asset LByteString) ->
(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
runEmaWithCli ::
forall model route b.
(Ema model route, Show route) =>
Cli ->
(Some CLI.Action -> model -> route -> Asset LByteString) ->
(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
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)
runEmaWithCliInCwd ::
forall model route m.
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>
Some CLI.Action ->
LVar model ->
(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
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)