Ema r & ModelFor r (#82)

* Change typeclass to be `Ema r`.

* Error out when allRoutes returns empty, in gen.

Fixes #73

* Fix runEmaPure and Ema instance for ()

* Update nixpkgs, and add bin/repl

CHANGELOG.md

@@ -3,6 +3,9 @@
 ## Unreleased
 
 - Fix bug in `Ex02_Basic.hs` (wasn't generating HTML files)
+- Fix `runEmaPure` not generating routes
+- Typeclass
+  - Change typeclass to be indexed only route (`Ema r`)
 
 ## 0.6.0.0 -- 2022-02-05
 

bin/repl

@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+set -xe
+
+exec nix develop -c cabal -- repl

ema.cabal

@@ -1,6 +1,6 @@
 cabal-version:      2.4
 name:               ema
-version:            0.6.0.1
+version:            0.7.0.0
 license:            AGPL-3.0-only
 copyright:          2021 Sridhar Ratnakumar
 maintainer:         srid@srid.ca

flake.lock

@@ -79,17 +79,17 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1643322911,
-        "narHash": "sha256-WLe4lXAYXH/v80iO02npX1wdXq4nIVEHJTONLXbQrL0=",
+        "lastModified": 1644486793,
+        "narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "d9e21f284317f85b3476c0043f4efea87a226c3a",
+        "rev": "1882c6b7368fd284ad01b0a5b5601ef136321292",
         "type": "github"
       },
       "original": {
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "d9e21f284317f85b3476c0043f4efea87a226c3a",
+        "rev": "1882c6b7368fd284ad01b0a5b5601ef136321292",
         "type": "github"
       }
     },

flake.nix

@@ -1,7 +1,7 @@
 {
   description = "Ema project";
   inputs = {
-    nixpkgs.url = "github:nixos/nixpkgs/d9e21f284317f85b3476c0043f4efea87a226c3a";
+    nixpkgs.url = "github:nixos/nixpkgs/1882c6b7368fd284ad01b0a5b5601ef136321292";
     flake-utils.url = "github:numtide/flake-utils";
     flake-compat = {
       url = "github:edolstra/flake-compat";

hie.yaml

@@ -1,4 +1,2 @@
 cradle:
   cabal:
-    - path: "./src"
-      component: "library:ema"

src/Ema/App.hs

@@ -20,7 +20,7 @@ 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.Class (Ema (..))
 import Ema.Generate qualified as Generate
 import Ema.Server qualified as Server
 import System.Directory (getCurrentDirectory)
@@ -45,8 +45,7 @@ runEmaPure render = do
   void $
     runEma (\act () () -> AssetGenerated Html $ render act) $ \act model -> do
       LVar.set model ()
-      when (CLI.isLiveServer act) $
-        liftIO $ threadDelay maxBound
+      liftIO $ threadDelay maxBound
 
 -- | Convenient version of @runEmaWith@ that takes initial model and an update
 -- function. You typically want to use this.
@@ -54,13 +53,13 @@ runEmaPure render = do
 -- 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) =>
+  forall r b.
+  (Ema r, Show r) =>
   -- | How to render a route, given the model
-  (Some CLI.Action -> model -> route -> Asset LByteString) ->
+  (Some CLI.Action -> ModelFor r -> r -> 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) ->
+  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => Some CLI.Action -> LVar (ModelFor r) -> m b) ->
   IO (Either b (DSum CLI.Action Identity))
 runEma render runModel = do
   cli <- CLI.cliAction
@@ -70,14 +69,14 @@ runEma render runModel = do
 --
 -- Useful if you are handling CLI arguments yourself.
 runEmaWithCli ::
-  forall model route b.
-  (Ema model route, Show route) =>
+  forall r b.
+  (Ema r, Show r) =>
   Cli ->
   -- | How to render a route, given the model
-  (Some CLI.Action -> model -> route -> Asset LByteString) ->
+  (Some CLI.Action -> ModelFor r -> r -> 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) ->
+  (forall m. (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) => Some CLI.Action -> LVar (ModelFor r) -> m b) ->
   IO (Either b (DSum CLI.Action Identity))
 runEmaWithCli cli render runModel = do
   model <- LVar.empty
@@ -93,8 +92,8 @@ runEmaWithCli cli render runModel = do
 
 -- | Run Ema live dev server
 runEmaWithCliInCwd ::
-  forall model route m.
-  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>
+  forall r m.
+  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema r, Show r) =>
   -- | CLI arguments
   Some CLI.Action ->
   -- | Your site model type, as a @LVar@ in order to support modifications over
@@ -103,11 +102,11 @@ runEmaWithCliInCwd ::
   -- 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 ->
+  LVar (ModelFor r) ->
   -- | 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) ->
+  (Some CLI.Action -> ModelFor r -> r -> Asset LByteString) ->
   m (DSum CLI.Action Identity)
 runEmaWithCliInCwd cliAction model render = do
   val <- LVar.get model

src/Ema/Class.hs

@@ -1,29 +1,31 @@
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FunctionalDependencies #-}
 
 module Ema.Class where
 
 -- | Enrich a model to work with Ema
-class Ema model route | route -> model where
+class Ema r where
+  type ModelFor r :: Type
+
   -- | Get the filepath on disk corresponding to this route.
-  encodeRoute :: model -> route -> FilePath
+  encodeRoute :: ModelFor r -> r -> FilePath
 
   -- | Decode a filepath on disk into a route.
-  decodeRoute :: model -> FilePath -> Maybe route
+  decodeRoute :: ModelFor r -> FilePath -> Maybe r
 
   -- | All routes in the site
   --
   -- The `gen` command will generate only these routes. On live server, this
   -- function is never used.
-  allRoutes :: model -> [route]
-  default allRoutes :: (Bounded route, Enum route) => model -> [route]
+  allRoutes :: ModelFor r -> [r]
+  default allRoutes :: (Bounded r, Enum r) => ModelFor r -> [r]
   allRoutes _ = [minBound .. maxBound]
 
 -- | 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 () () = []
+instance Ema () where
+  type ModelFor () = ()
+  encodeRoute () () = "index.html"
   decodeRoute () = \case
-    [] -> Just ()
+    "index.html" -> Just ()
     _ -> Nothing
   allRoutes () = one ()

src/Ema/Example/Ex02_Basic.hs

@@ -5,7 +5,6 @@ import Control.Concurrent (threadDelay)
 import Data.LVar qualified as LVar
 import Ema (Ema (..))
 import Ema qualified
-import Ema.CLI qualified as CLI
 import Ema.Example.Common (tailwindLayout)
 import Text.Blaze.Html5 ((!))
 import Text.Blaze.Html5 qualified as H
@@ -18,7 +17,8 @@ data Route
 
 newtype Model = Model {unModel :: Text}
 
-instance Ema Model Route where
+instance Ema Route where
+  type ModelFor Route = Model
   encodeRoute _model =
     \case
       Index -> "index.html"
@@ -31,7 +31,7 @@ instance Ema Model Route where
 main :: IO ()
 main = do
   void $
-    Ema.runEma (\_act m -> Ema.AssetGenerated Ema.Html . render m) $ \act model -> do
+    Ema.runEma (\_act m -> Ema.AssetGenerated Ema.Html . render m) $ \_act model -> do
       LVar.set model $ Model "Hello World. "
       liftIO $ threadDelay maxBound
 

src/Ema/Example/Ex03_Clock.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 -- | A very simple site with routes, but based on dynamically changing values
 --
 -- The current time is computed in the server every second, and the resultant
@@ -24,7 +22,8 @@ data Route
   | OnlyTime
   deriving stock (Show, Enum, Bounded)
 
-instance Ema UTCTime Route where
+instance Ema Route where
+  type ModelFor Route = UTCTime
   encodeRoute _time = \case
     Index -> "index.html"
     OnlyTime -> "time.html"

src/Ema/Generate.hs

@@ -6,7 +6,7 @@ module Ema.Generate where
 import Control.Exception (throw)
 import Control.Monad.Logger
 import Ema.Asset (Asset (..))
-import Ema.Class (Ema (allRoutes, encodeRoute))
+import Ema.Class (Ema (..))
 import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist)
 import System.FilePath (takeDirectory, (</>))
 import System.FilePattern.Directory (getDirectoryFiles)
@@ -16,22 +16,25 @@ log :: MonadLogger m => LogLevel -> Text -> m ()
 log = logWithoutLoc "Generate"
 
 generate ::
-  forall model route m.
+  forall r m.
   ( MonadIO m,
     MonadUnliftIO m,
     MonadLoggerIO m,
-    Ema model route,
+    Ema r,
+    Show r,
     HasCallStack
   ) =>
   FilePath ->
-  model ->
-  (model -> route -> Asset LByteString) ->
+  ModelFor r ->
+  (ModelFor r -> r -> Asset LByteString) ->
   -- | List of generated files.
   m [FilePath]
 generate dest model render = do
   unlessM (liftIO $ doesDirectoryExist dest) $ do
     error $ "Destination does not exist: " <> toText dest
   let routes = allRoutes model
+  when (null routes) $
+    error "allRoutes is empty; nothing to generate"
   log LevelInfo $ "Writing " <> show (length routes) <> " routes"
   let (staticPaths, generatedPaths) =
         lefts &&& rights $

src/Ema/Route.hs

@@ -9,7 +9,7 @@ import Data.Aeson (FromJSON (parseJSON), Value)
 import Data.Aeson.Types (Parser)
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
-import Ema.Class (Ema (encodeRoute))
+import Ema.Class (Ema (ModelFor, encodeRoute))
 import Network.URI.Slug qualified as Slug
 
 data UrlStrategy
@@ -31,7 +31,7 @@ instance FromJSON UrlStrategy where
 --
 -- 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.
-routeUrlWith :: forall r model. Ema model r => UrlStrategy -> model -> r -> Text
+routeUrlWith :: forall r. Ema r => UrlStrategy -> ModelFor r -> r -> Text
 routeUrlWith urlStrategy model =
   relUrlFromPath . encodeRoute model
   where
@@ -57,6 +57,6 @@ routeUrlWith urlStrategy model =
           UrlPretty -> ".html"
           UrlDirect -> ""
 
-routeUrl :: forall r model. Ema model r => model -> r -> Text
+routeUrl :: forall r. Ema r => ModelFor r -> r -> Text
 routeUrl =
   routeUrlWith UrlPretty

src/Ema/Server.hs

@@ -39,17 +39,17 @@ instance Default Port where
   def = 8000
 
 runServerWithWebSocketHotReload ::
-  forall model route m.
-  ( Ema model route,
-    Show route,
+  forall r m.
+  ( Ema r,
+    Show r,
     MonadIO m,
     MonadUnliftIO m,
     MonadLoggerIO m
   ) =>
   Host ->
   Port ->
-  LVar model ->
-  (model -> route -> Asset LByteString) ->
+  LVar (ModelFor r) ->
+  (ModelFor r -> r -> Asset LByteString) ->
   m ()
 runServerWithWebSocketHotReload host port model render = do
   let settings =
@@ -195,11 +195,11 @@ pathInfoFromWsMsg =
 -- | Decode a URL path into a route
 --
 -- This function is used only in live server.
-decodeUrlRoute :: forall model route. Ema model route => model -> Text -> Maybe route
+decodeUrlRoute :: forall r. Ema r => ModelFor r -> Text -> Maybe r
 decodeUrlRoute model (toString -> s) = do
-  decodeRoute @model @route model s
-    <|> decodeRoute @model @route model (s <> ".html")
-    <|> decodeRoute @model @route model (s </> "index.html")
+  decodeRoute @r model s
+    <|> decodeRoute @r model (s <> ".html")
+    <|> decodeRoute @r model (s </> "index.html")
 
 decodeRouteNothingMsg :: Text
 decodeRouteNothingMsg = "Ema: 404 (decodeRoute returned Nothing)"