refactor Ema.Route

README.md

@@ -23,7 +23,7 @@ Open in VSCode, and run the build task.
 ## TODO
 
 - [x] MVP
-- [ ] Implement hot reload, and ditch browser-sync
+- [x] Implement hot reload, and ditch browser-sync
   - [x] server to client refresh
   - [x] client to server reconnect (on ghcid reload, or accidental client disconnect)
     - [x] or, investigate https://hackage.haskell.org/package/ghci-websockets

ema.cabal

@@ -74,6 +74,8 @@ library
     Ema.Example
     Ema.Layout
     Ema.Route
+    Ema.Route.Slug
+    Ema.Route.UrlStrategy
 
   hs-source-dirs:     src
   default-language:   Haskell2010

src/Ema/App.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TypeApplications #-}
 
+-- | TODO: Refactor this module
 module Ema.App where
 
 import Control.Concurrent.Async (race_)

src/Ema/Example.hs

@@ -62,31 +62,30 @@ timeC = do
 runSimpleSitePure :: IO ()
 runSimpleSitePure = do
   (model, runTimeC) <- timeC
-  race_ runTimeC (runEma $ ema model)
+  race_ runTimeC (runEma $ Ema model render)
   where
-    ema model =
-      Ema model $ \now r ->
-        Layout.tailwindSite (H.title "Simple Site") $
-          H.div ! A.class_ "container mx-auto" $ do
-            H.header ! A.class_ "text-4xl font-bold border-b-1" $ "Simple Site!"
-            case r of
-              PR_Index -> do
-                H.p ! A.style "color: red; text-3xl" $ "Checkout some profiles:"
-                forM_ ["Srid Ratna", "ema", "Great India"] $ \person ->
-                  H.li $
-                    routeElem (PR_Person person) $
-                      H.toMarkup person
-              PR_Person name -> do
-                H.header ! A.class_ "text-2xl" $ H.toMarkup $ "Profile of " <> name
-                H.div $ routeElem PR_Index "Go to Home"
-            H.footer ! A.class_ "border-t-1 p-2 text-center" $ do
-              "The current time is: "
-              H.pre ! A.class_ "text-4xl" $ do
-                let epoch = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" now
-                    colors = ["green", "purple", "red", "blue"]
-                    color = colors !! mod epoch (length colors)
-                    cls = "text-" <> color <> "-500"
-                H.span ! A.class_ cls $ H.toMarkup $ formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" now
+    render now r =
+      Layout.tailwindSite (H.title "Simple Site") $
+        H.div ! A.class_ "container mx-auto" $ do
+          H.header ! A.class_ "text-4xl font-bold border-b-1" $ "Simple Site!"
+          case r of
+            PR_Index -> do
+              H.p ! A.style "color: red; text-3xl" $ "Checkout some profiles:"
+              forM_ ["Srid Ratna", "ema", "Great India"] $ \person ->
+                H.li $
+                  routeElem (PR_Person person) $
+                    H.toMarkup person
+            PR_Person name -> do
+              H.header ! A.class_ "text-2xl" $ H.toMarkup $ "Profile of " <> name
+              H.div $ routeElem PR_Index "Go to Home"
+          H.footer ! A.class_ "border-t-1 p-2 text-center" $ do
+            "The current time is: "
+            H.pre ! A.class_ "text-4xl" $ do
+              let epoch = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" now
+                  colors = ["green", "purple", "red", "blue"]
+                  color = colors !! mod epoch (length colors)
+                  cls = "text-" <> color <> "-500"
+              H.span ! A.class_ cls $ H.toMarkup $ formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" now
     routeElem r w =
       H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r $ w
     routeHref r =

src/Ema/Route.hs

@@ -1,25 +1,17 @@
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Ema.Route where
+module Ema.Route
+  ( IsRoute (..),
+    Slug (unSlug),
+  )
+where
 
-import Data.Default (Default, def)
-import qualified Data.Text as T
-import System.FilePath (joinPath)
-
--- ---- [Slug] ----
-
-newtype Slug = Slug {unSlug :: Text}
-  deriving (Eq)
-
-instance IsString Slug where
-  fromString :: HasCallStack => String -> Slug
-  fromString (toText -> s) =
-    if "/" `T.isInfixOf` s
-      then error ("Slug cannot contain a slash: " <> s)
-      else Slug s
-
--- ---- [Route] ----
+import Data.Default (def)
+import Ema.Route.Slug (Slug (unSlug))
+import Ema.Route.UrlStrategy
+  ( routeFileWithStrategy,
+    routeUrlWithStrategy,
+  )
 
 class IsRoute r where
   -- | Determine the route for the given URL slug
@@ -31,53 +23,16 @@ class IsRoute r where
   -- | Relative URL to use in "href"
   routeUrl :: r -> Text
   routeUrl =
-    routeUrlWithStrategy def
+    routeUrlWithStrategy def . toSlug
 
   -- | Relative file path to .html file correspondong to this route.
   routeFile :: r -> FilePath
   routeFile =
-    routeFileWithStrategy def
+    routeFileWithStrategy def . toSlug
 
+-- The unit route is used for sites that have a single route, i.e. index.html.
 instance IsRoute () where
   fromSlug = \case
     [] -> Just ()
     _ -> Nothing
   toSlug () = []
-
--- ---- [UrlStrategy] ----
-
-data UrlStrategy
-  = UrlStrategy_FolderOnly
-  | -- | Pretty URLs without ugly .html ext or slash-suffix
-    UrlStrategy_HtmlOnlySansExt
-  deriving (Eq, Show, Ord)
-
-instance Default UrlStrategy where
-  def = UrlStrategy_HtmlOnlySansExt
-
-routeUrlWithStrategy :: IsRoute r => UrlStrategy -> r -> Text
-routeUrlWithStrategy strat r =
-  case strat of
-    UrlStrategy_FolderOnly ->
-      "/" <> T.replace "index.html" "" (toText $ routeFile r)
-    UrlStrategy_HtmlOnlySansExt ->
-      -- FIXME: This should replace only at the end, not middle
-      let fp = toText (routeFile r)
-       in if
-              | "index.html" == fp ->
-                "/"
-              | "/index.html" `T.isSuffixOf` fp ->
-                "/" <> T.take (T.length fp - T.length "/index.html") fp
-              | ".html" `T.isSuffixOf` fp ->
-                "/" <> T.take (T.length fp - T.length ".html") fp
-              | otherwise ->
-                "/" <> fp
-
-routeFileWithStrategy :: IsRoute r => UrlStrategy -> r -> FilePath
-routeFileWithStrategy strat (toSlug -> slugs) =
-  case strat of
-    UrlStrategy_FolderOnly ->
-      joinPath $ fmap (toString . unSlug) slugs <> ["index.html"]
-    UrlStrategy_HtmlOnlySansExt ->
-      let (term :| (reverse -> parts)) = fromMaybe ("index" :| []) $ nonEmpty (reverse $ fmap unSlug slugs)
-       in joinPath $ fmap toString parts <> [toString term <> ".html"]

src/Ema/Route/Slug.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE InstanceSigs #-}
+
+module Ema.Route.Slug where
+
+import qualified Data.Text as T
+
+-- ---- [Slug] ----
+
+newtype Slug = Slug {unSlug :: Text}
+  deriving (Eq)
+
+instance IsString Slug where
+  fromString :: HasCallStack => String -> Slug
+  fromString (toText -> s) =
+    if "/" `T.isInfixOf` s
+      then error ("Slug cannot contain a slash: " <> s)
+      else Slug s

src/Ema/Route/UrlStrategy.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Ema.Route.UrlStrategy where
+
+import Data.Default (Default, def)
+import qualified Data.Text as T
+import Ema.Route.Slug (Slug (unSlug))
+import System.FilePath (joinPath)
+
+data UrlStrategy
+  = UrlStrategy_FolderOnly
+  | -- | Pretty URLs without ugly .html ext or slash-suffix
+    UrlStrategy_HtmlOnlySansExt
+  deriving (Eq, Show, Ord)
+
+instance Default UrlStrategy where
+  def = UrlStrategy_HtmlOnlySansExt
+
+routeUrlWithStrategy :: UrlStrategy -> [Slug] -> Text
+routeUrlWithStrategy strat slugs =
+  case strat of
+    UrlStrategy_FolderOnly ->
+      "/" <> T.replace "index.html" "" (toText $ routeFileWithStrategy strat slugs)
+    UrlStrategy_HtmlOnlySansExt ->
+      -- FIXME: This should replace only at the end, not middle
+      let fp = toText (routeFileWithStrategy strat slugs)
+       in if
+              | "index.html" == fp ->
+                "/"
+              | "/index.html" `T.isSuffixOf` fp ->
+                "/" <> T.take (T.length fp - T.length "/index.html") fp
+              | ".html" `T.isSuffixOf` fp ->
+                "/" <> T.take (T.length fp - T.length ".html") fp
+              | otherwise ->
+                "/" <> fp
+
+routeFileWithStrategy :: UrlStrategy -> [Slug] -> FilePath
+routeFileWithStrategy strat slugs =
+  case strat of
+    UrlStrategy_FolderOnly ->
+      joinPath $ fmap (toString . unSlug) slugs <> ["index.html"]
+    UrlStrategy_HtmlOnlySansExt ->
+      let (term :| (reverse -> parts)) = fromMaybe ("index" :| []) $ nonEmpty (reverse $ fmap unSlug slugs)
+       in joinPath $ fmap toString parts <> [toString term <> ".html"]