1
1
mirror of https://github.com/srid/ema.git synced 2024-12-02 09:15:10 +03:00

Drop Ema typeclass; add back as HtmlRoute typeclass

This commit is contained in:
Sridhar Ratnakumar 2021-05-21 16:19:57 -04:00
parent 61b3191792
commit 2d6bb31467
9 changed files with 47 additions and 52 deletions

View File

@ -112,7 +112,6 @@ library
other-modules: other-modules:
Ema.App Ema.App
Ema.Class
Ema.Generate Ema.Generate
Ema.Route Ema.Route
Ema.Route.Slug Ema.Route.Slug

View File

@ -6,5 +6,4 @@ module Ema
where where
import Ema.App as X import Ema.App as X
import Ema.Class as X
import Ema.Route as X import Ema.Route as X

View File

@ -8,7 +8,6 @@ module Ema.App
( runEma, ( runEma,
runEmaPure, runEmaPure,
runEmaWithCli, runEmaWithCli,
MonadEma,
) )
where where
@ -20,11 +19,12 @@ import Data.LVar (LVar)
import qualified Data.LVar as LVar import qualified Data.LVar as LVar
import Ema.CLI (Action (..), Cli) import Ema.CLI (Action (..), Cli)
import qualified Ema.CLI as CLI import qualified Ema.CLI as CLI
import Ema.Class (Ema (..), MonadEma)
import qualified Ema.Generate as Generate import qualified Ema.Generate as Generate
import Ema.Route (HtmlRoute (..))
import qualified Ema.Server as Server import qualified Ema.Server as Server
import System.Directory (getCurrentDirectory, withCurrentDirectory) import System.Directory (getCurrentDirectory, withCurrentDirectory)
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
import UnliftIO (MonadUnliftIO)
-- | Pure version of @runEmaWith@ (i.e with no model). -- | Pure version of @runEmaWith@ (i.e with no model).
-- --
@ -48,14 +48,14 @@ runEmaPure render = do
-- exits, and vice-versa. -- exits, and vice-versa.
runEma :: runEma ::
forall model route. forall model route.
(Ema route, Show route) => (HtmlRoute route, Show route) =>
[FilePath] -> [FilePath] ->
(model -> [route]) -> (model -> [route]) ->
-- | How to render a route, given the model -- | How to render a route, given the model
(CLI.Action -> model -> route -> LByteString) -> (CLI.Action -> model -> route -> LByteString) ->
-- | A long-running IO action that will update the @model@ @LVar@ over time. -- | 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. -- This IO action must set the initial model value in the very beginning.
(forall m. MonadEma m => LVar model -> m ()) -> (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => LVar model -> m ()) ->
IO () IO ()
runEma staticAssets staticRoutes render runModel = do runEma staticAssets staticRoutes render runModel = do
cli <- CLI.cliAction cli <- CLI.cliAction
@ -66,7 +66,7 @@ runEma staticAssets staticRoutes render runModel = do
-- Useful if you are handling CLI arguments yourself. -- Useful if you are handling CLI arguments yourself.
runEmaWithCli :: runEmaWithCli ::
forall model route. forall model route.
(Ema route, Show route) => (HtmlRoute route, Show route) =>
Cli -> Cli ->
[FilePath] -> [FilePath] ->
(model -> [route]) -> (model -> [route]) ->
@ -74,7 +74,7 @@ runEmaWithCli ::
(CLI.Action -> model -> route -> LByteString) -> (CLI.Action -> model -> route -> LByteString) ->
-- | A long-running IO action that will update the @model@ @LVar@ over time. -- | 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. -- This IO action must set the initial model value in the very beginning.
(forall m. MonadEma m => LVar model -> m ()) -> (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => LVar model -> m ()) ->
IO () IO ()
runEmaWithCli cli staticAssets staticRoutes render runModel = do runEmaWithCli cli staticAssets staticRoutes render runModel = do
model <- LVar.empty model <- LVar.empty
@ -93,7 +93,7 @@ runEmaWithCli cli staticAssets staticRoutes render runModel = do
-- | Run Ema live dev server -- | Run Ema live dev server
runEmaWithCliInCwd :: runEmaWithCliInCwd ::
forall model route m. forall model route m.
(MonadEma m, Ema route, Show route) => (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, HtmlRoute route, Show route) =>
-- | CLI arguments -- | CLI arguments
CLI.Action -> CLI.Action ->
-- | Your site model type, as a @LVar@ in order to support modifications over -- | Your site model type, as a @LVar@ in order to support modifications over

View File

@ -1,29 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Ema.Class where
import Control.Monad.Logger (MonadLoggerIO)
import Ema.Route.Slug (Slug)
import UnliftIO (MonadUnliftIO)
type MonadEma m =
( MonadIO m,
MonadUnliftIO m,
MonadLoggerIO m
)
-- | Enrich a model to work with Ema
class Ema route where
-- How to convert URLs to/from routes
encodeRoute :: route -> [Slug]
decodeRoute :: [Slug] -> Maybe route
-- | The unit model is useful when using Ema in pure fashion (see @Ema.runEmaPure@) with a single route (index.html) only.
instance Ema () where
encodeRoute () = []
decodeRoute = \case
[] -> Just ()
_ -> Nothing

View File

@ -10,7 +10,7 @@ module Ema.Example.Ex02_Basic where
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import qualified Data.LVar as LVar import qualified Data.LVar as LVar
import Ema (Ema (..)) import Ema (HtmlRoute (..))
import qualified Ema import qualified Ema
import qualified Ema.CLI import qualified Ema.CLI
import qualified Ema.Helper.Tailwind as Tailwind import qualified Ema.Helper.Tailwind as Tailwind
@ -25,7 +25,7 @@ data Route
data Model = Model Text data Model = Model Text
instance Ema Route where instance HtmlRoute Route where
encodeRoute = \case encodeRoute = \case
Index -> mempty Index -> mempty
About -> one "about" About -> one "about"

View File

@ -13,7 +13,7 @@ import Control.Concurrent (threadDelay)
import qualified Data.LVar as LVar import qualified Data.LVar as LVar
import Data.List ((!!)) import Data.List ((!!))
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Ema (Ema (..), routeUrl, runEma) import Ema (HtmlRoute (..), routeUrl, runEma)
import qualified Ema.CLI import qualified Ema.CLI
import qualified Ema.Helper.Tailwind as Tailwind import qualified Ema.Helper.Tailwind as Tailwind
import Text.Blaze.Html5 ((!)) import Text.Blaze.Html5 ((!))
@ -25,7 +25,7 @@ data Route
| OnlyTime | OnlyTime
deriving (Show, Enum, Bounded) deriving (Show, Enum, Bounded)
instance Ema Route where instance HtmlRoute Route where
encodeRoute = \case encodeRoute = \case
Index -> mempty Index -> mempty
OnlyTime -> one "time" OnlyTime -> one "time"

View File

@ -6,18 +6,22 @@ module Ema.Generate where
import Control.Exception (throw) import Control.Exception (throw)
import Control.Monad.Logger import Control.Monad.Logger
import Ema.Class (Ema, MonadEma) import Ema.Route (HtmlRoute, routeFile)
import Ema.Route (routeFile)
import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist)
import System.FilePath (takeDirectory, (</>)) import System.FilePath (takeDirectory, (</>))
import System.FilePattern.Directory (getDirectoryFiles) import System.FilePattern.Directory (getDirectoryFiles)
import UnliftIO (MonadUnliftIO)
log :: MonadLogger m => LogLevel -> Text -> m () log :: MonadLogger m => LogLevel -> Text -> m ()
log = logWithoutLoc "Generate" log = logWithoutLoc "Generate"
generate :: generate ::
forall model route m. forall model route m.
(MonadEma m, Ema route) => ( MonadIO m,
MonadUnliftIO m,
MonadLoggerIO m,
HtmlRoute route
) =>
FilePath -> FilePath ->
model -> model ->
[FilePath] -> [FilePath] ->
@ -46,7 +50,10 @@ newtype StaticAssetMissing = StaticAssetMissing FilePath
deriving (Show, Exception) deriving (Show, Exception)
copyDirRecursively :: copyDirRecursively ::
MonadEma m => ( MonadIO m,
MonadUnliftIO m,
MonadLoggerIO m
) =>
-- | Source file or directory relative to CWD that will be copied -- | Source file or directory relative to CWD that will be copied
FilePath -> FilePath ->
-- | Directory *under* which the source file/dir will be copied -- | Directory *under* which the source file/dir will be copied

View File

@ -2,7 +2,8 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Ema.Route module Ema.Route
( routeUrl, ( HtmlRoute (..),
routeUrl,
routeFile, routeFile,
Slug (unSlug), Slug (unSlug),
decodeSlug, decodeSlug,
@ -12,7 +13,6 @@ module Ema.Route
where where
import Data.Default (def) import Data.Default (def)
import Ema.Class
import Ema.Route.Slug (Slug (unSlug), decodeSlug, encodeSlug) import Ema.Route.Slug (Slug (unSlug), decodeSlug, encodeSlug)
import Ema.Route.UrlStrategy import Ema.Route.UrlStrategy
( UrlStrategy (..), ( UrlStrategy (..),
@ -20,14 +20,27 @@ import Ema.Route.UrlStrategy
slugRelUrlWithStrategy, slugRelUrlWithStrategy,
) )
-- | Route to the generated HTML file.
class HtmlRoute route where
-- How to convert URLs to/from routes
encodeRoute :: route -> [Slug]
decodeRoute :: [Slug] -> Maybe route
-- | The unit model is useful when using Ema in pure fashion (see @Ema.runEmaPure@) with a single route (index.html) only.
instance HtmlRoute () where
encodeRoute () = []
decodeRoute = \case
[] -> Just ()
_ -> Nothing
-- | Return the relative URL of the given route -- | Return the relative URL of the given route
-- --
-- As the returned URL is relative, you will have to either make it absolute (by -- As the returned URL is relative, you will have to either make it absolute (by
-- prepending with `/`) or set the `<base>` URL in your HTML head element. -- prepending with `/`) or set the `<base>` URL in your HTML head element.
routeUrl :: forall r. Ema r => r -> Text routeUrl :: forall r. HtmlRoute r => r -> Text
routeUrl r = routeUrl r =
slugRelUrlWithStrategy def (encodeRoute r) slugRelUrlWithStrategy def (encodeRoute r)
routeFile :: forall r. Ema r => r -> FilePath routeFile :: forall r. HtmlRoute r => r -> FilePath
routeFile r = routeFile r =
slugFileWithStrategy def (encodeRoute r) slugFileWithStrategy def (encodeRoute r)

View File

@ -9,7 +9,7 @@ import Control.Monad.Logger
import Data.LVar (LVar) import Data.LVar (LVar)
import qualified Data.LVar as LVar import qualified Data.LVar as LVar
import qualified Data.Text as T import qualified Data.Text as T
import Ema.Class (Ema (decodeRoute), MonadEma) import Ema.Route (HtmlRoute (..))
import qualified Ema.Route.Slug as Slug import qualified Ema.Route.Slug as Slug
import GHC.IO.Unsafe (unsafePerformIO) import GHC.IO.Unsafe (unsafePerformIO)
import NeatInterpolation (text) import NeatInterpolation (text)
@ -22,10 +22,16 @@ import Network.WebSockets (ConnectionException)
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import Relude.Extra.Foldable1 (foldl1') import Relude.Extra.Foldable1 (foldl1')
import Text.Printf (printf) import Text.Printf (printf)
import UnliftIO (MonadUnliftIO)
runServerWithWebSocketHotReload :: runServerWithWebSocketHotReload ::
forall model route m. forall model route m.
(Ema route, Show route, MonadEma m) => ( HtmlRoute route,
Show route,
MonadIO m,
MonadUnliftIO m,
MonadLoggerIO m
) =>
Int -> Int ->
LVar model -> LVar model ->
[FilePath] -> [FilePath] ->