{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# 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.LVar (LVar)
import qualified Data.LVar as LVar
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 System.Environment (lookupEnv)
import UnliftIO (BufferMode (BlockBuffering, LineBuffering), MonadUnliftIO, hFlush, hSetBuffering)
runEmaPure ::
(CLI.Action -> LByteString) ->
IO ()
runEmaPure :: (Action -> LByteString) -> IO ()
runEmaPure Action -> LByteString
render = do
(Action -> () -> () -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar () -> m ())
-> IO ()
forall model route.
(Ema model route, Show route) =>
(Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ())
-> IO ()
runEma (\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
$ Action -> LByteString
render Action
act) ((forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar () -> m ())
-> IO ())
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar () -> m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \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 (Action
act Action -> Action -> Bool
forall a. Eq a => a -> a -> Bool
== Action
CLI.Run) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
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.
(Ema model route, Show route) =>
(CLI.Action -> model -> route -> Asset LByteString) ->
(forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) ->
IO ()
runEma :: (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ())
-> IO ()
runEma Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel = do
Cli
cli <- IO Cli
CLI.cliAction
Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ())
-> IO ()
forall model route.
(Ema model route, Show route) =>
Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ())
-> IO ()
runEmaWithCli Cli
cli Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel
runEmaWithCli ::
forall model route.
(Ema model route, Show route) =>
Cli ->
(CLI.Action -> model -> route -> Asset LByteString) ->
(forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => CLI.Action -> LVar model -> m ()) ->
IO ()
runEmaWithCli :: Cli
-> (Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ())
-> IO ()
runEmaWithCli Cli
cli Action -> model -> route -> Asset LByteString
render forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
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 () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_
((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
$ Action -> LVar model -> LoggingT IO ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Action -> LVar model -> m ()
runModel (Cli -> Action
CLI.action Cli
cli) LVar model
model)
((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
$ Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> LoggingT IO ()
forall model route (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
Show route) =>
Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> m ()
runEmaWithCliInCwd (Cli -> Action
CLI.action Cli
cli) LVar model
model Action -> model -> route -> Asset LByteString
render)
runEmaWithCliInCwd ::
forall model route m.
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>
CLI.Action ->
LVar model ->
(CLI.Action -> model -> route -> Asset LByteString) ->
m ()
runEmaWithCliInCwd :: Action
-> LVar model
-> (Action -> model -> route -> Asset LByteString)
-> m ()
runEmaWithCliInCwd Action
cliAction LVar model
model 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 Action
cliAction of
CLI.Generate FilePath
dest -> do
m () -> m ()
forall (f :: * -> *) a. MonadIO f => f a -> f a
withBlockBuffering (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> model -> (model -> route -> Asset LByteString) -> m ()
forall model route (m :: * -> *).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route,
HasCallStack) =>
FilePath -> model -> (model -> route -> Asset LByteString) -> m ()
Generate.generate FilePath
dest model
val (Action -> model -> route -> Asset LByteString
render Action
cliAction)
Action
CLI.Run -> do
Int
port <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
8000 (Maybe Int -> Int)
-> (Maybe FilePath -> Maybe Int) -> Maybe FilePath -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Read Int => FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe @Int (FilePath -> Maybe Int) -> Maybe FilePath -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe FilePath -> Int) -> IO (Maybe FilePath) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"PORT"
FilePath
host <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"127.0.0.1" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"HOST"
FilePath
-> Int
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
forall model route (m :: * -> *).
(Ema model route, Show route, MonadIO m, MonadUnliftIO m,
MonadLoggerIO m) =>
FilePath
-> Int
-> LVar model
-> (model -> route -> Asset LByteString)
-> m ()
Server.runServerWithWebSocketHotReload FilePath
host Int
port LVar model
model (Action -> model -> route -> Asset LByteString
render Action
cliAction)
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)