Refactor doc example

src/Ema/Example/Ex03_Documentation.hs

@@ -36,34 +36,34 @@ import Text.Pandoc.Definition (Pandoc (..))
 import qualified Text.Pandoc.Walk as W
 
 -- | Represents the relative path to a source (.md) file under some directory.
-type SourcePath = Tagged "SourcePath" (NonEmpty Text)
+type MarkdownPath = Tagged "MarkdownPath" (NonEmpty Text)
 
-indexSourcePath :: SourcePath
-indexSourcePath = Tagged $ "index" :| []
+indexMarkdownPath :: MarkdownPath
+indexMarkdownPath = Tagged $ "index" :| []
 
-mkSourcePath :: FilePath -> Maybe SourcePath
-mkSourcePath = \case
+mkMarkdownPath :: FilePath -> Maybe MarkdownPath
+mkMarkdownPath = \case
   (splitExtension -> (fp, ".md")) ->
     let slugs = T.dropWhileEnd (== '/') . toText <$> splitPath fp
      in Tagged <$> nonEmpty slugs
   _ ->
     Nothing
 
-sourcePathFileBase :: SourcePath -> Text
-sourcePathFileBase (Tagged slugs) =
+markdownPathFileBase :: MarkdownPath -> Text
+markdownPathFileBase (Tagged slugs) =
   head $ NE.reverse slugs
 
-sourcePathInits :: SourcePath -> NonEmpty SourcePath
-sourcePathInits (Tagged ("index" :| [])) =
-  one indexSourcePath
-sourcePathInits (Tagged (slug :| rest')) =
-  indexSourcePath :| case nonEmpty rest' of
+markdownPathInits :: MarkdownPath -> NonEmpty MarkdownPath
+markdownPathInits (Tagged ("index" :| [])) =
+  one indexMarkdownPath
+markdownPathInits (Tagged (slug :| rest')) =
+  indexMarkdownPath :| case nonEmpty rest' of
     Nothing ->
       one $ Tagged (one slug)
     Just rest ->
       Tagged (one slug) : go (one slug) rest
   where
-    go :: NonEmpty Text -> NonEmpty Text -> [SourcePath]
+    go :: NonEmpty Text -> NonEmpty Text -> [MarkdownPath]
     go x (y :| ys') =
       let this = Tagged (x <> one y)
        in case nonEmpty ys' of
@@ -72,9 +72,9 @@ sourcePathInits (Tagged (slug :| rest')) =
             Just ys ->
               this : go (untag this) ys
 
-type Sources = Tagged "Sources" (Map SourcePath Pandoc)
+type MarkdownSources = Tagged "MarkdownSources" (Map MarkdownPath Pandoc)
 
-instance Ema Sources SourcePath where
+instance Ema MarkdownSources MarkdownPath where
   encodeRoute = \case
     Tagged ("index" :| []) -> mempty
     Tagged paths -> toList . fmap (fromString . toString) $ paths
@@ -105,38 +105,55 @@ main =
           putStrLn $ "Update: " <> show spath
           LVar.modify model $ Tagged . Map.insert spath s . untag
       FileSystem.Delete ->
-        whenJust (mkSourcePath fp) $ \spath -> do
+        whenJust (mkMarkdownPath fp) $ \spath -> do
           putStrLn $ "Delete: " <> show spath
           LVar.modify model $ Tagged . Map.delete spath . untag
   where
-    readSource :: FilePath -> IO (Maybe (SourcePath, Pandoc))
+    readSource :: FilePath -> IO (Maybe (MarkdownPath, Pandoc))
     readSource fp =
       runMaybeT $ do
-        spath :: SourcePath <- MaybeT $ pure $ mkSourcePath fp
+        spath :: MarkdownPath <- MaybeT $ pure $ mkMarkdownPath fp
         s <- readFileText fp
         pure (spath, parseMarkdown s)
 
-newtype BadRoute = BadRoute SourcePath
+newtype BadRoute = BadRoute MarkdownPath
   deriving (Show, Exception)
 
-render :: Ema.CLI.Action -> Sources -> SourcePath -> LByteString
+render :: Ema.CLI.Action -> MarkdownSources -> MarkdownPath -> LByteString
 render emaAction srcs spath = do
-  let siteTitle = "Ema"
   case Map.lookup spath (untag srcs) of
     Nothing -> throw $ BadRoute spath
     Just doc -> do
-      let title = maybe (last $ untag spath) plainify $ getPandocH1 doc
-          headWidget = do
+      Tailwind.layout emaAction (headHtml spath doc) (bodyHtml srcs spath doc)
+
+headHtml :: MarkdownPath -> Pandoc -> H.Html
+headHtml spath doc = do
+  let siteTitle = "Ema"
+      routeTitle = maybe (last $ untag spath) plainify $ getPandocH1 doc
   H.title $
     H.text $
-                if title == siteTitle then siteTitle else title <> " – " <> siteTitle
+      if routeTitle == siteTitle then siteTitle else routeTitle <> " – " <> siteTitle
   H.meta ! A.name "description" ! A.content "Ema static site generator (Jamstack) in Haskell"
   favIcon
-            -- Need to support static files, first. cf. https://web.dev/themed-omnibox/
+  -- Make this a PWA and w/ https://web.dev/themed-omnibox/
   H.link ! A.rel "manifest" ! A.href "/manifest.json"
   H.meta ! A.name "theme-color" ! A.content "#d53f8c"
-            unless (spath == indexSourcePath) prismJs
-      Tailwind.layout emaAction headWidget $ do
+  unless (spath == indexMarkdownPath) prismJs
+  where
+    prismJs = do
+      H.unsafeByteString . encodeUtf8 $
+        [text|
+        <link href="https://cdn.jsdelivr.net/npm/prismjs@1.23.0/themes/prism-tomorrow.css" rel="stylesheet" />
+        <script src="https://cdn.jsdelivr.net/combine/npm/prismjs@1.23.0/prism.min.js,npm/prismjs@1.23.0/plugins/autoloader/prism-autoloader.min.js"></script>
+        |]
+    favIcon = do
+      H.unsafeByteString . encodeUtf8 $
+        [text|
+        <link href="/ema.svg" rel="icon" />
+        |]
+
+bodyHtml :: MarkdownSources -> MarkdownPath -> Pandoc -> H.Html
+bodyHtml srcs spath doc = do
   H.div ! A.class_ "flex justify-center p-4 bg-red-500 text-gray-100 font-bold text-2xl" $ do
     H.div $ do
       H.b "WIP: "
@@ -148,10 +165,10 @@ render emaAction srcs spath = do
         doc
           & applyClassLibrary (\c -> fromMaybe c $ Map.lookup c emaMarkdownStyleLibrary)
           & rewriteLinks
-                  -- Rewrite .md links to @SourcePath@
+            -- Rewrite .md links to @MarkdownPath@
             ( \url -> fromMaybe url $ do
                 guard $ not $ "://" `T.isInfixOf` url
-                      target <- mkSourcePath $ toString url
+                target <- mkMarkdownPath $ toString url
                 -- Check that .md links are not broken
                 if Map.member target (untag srcs)
                   then pure $ routeUrl target
@@ -171,28 +188,17 @@ render emaAction srcs spath = do
           ("last", "mt-8 border-t-2 border-pink-500 pb-1 pl-1 bg-gray-50 rounded"),
           ("next", "py-2 text-xl italic font-bold")
         ]
-    prismJs = do
-      H.unsafeByteString . encodeUtf8 $
-        [text|
-        <link href="https://cdn.jsdelivr.net/npm/prismjs@1.23.0/themes/prism-tomorrow.css" rel="stylesheet" />
-        <script src="https://cdn.jsdelivr.net/combine/npm/prismjs@1.23.0/prism.min.js,npm/prismjs@1.23.0/plugins/autoloader/prism-autoloader.min.js"></script>
-        |]
-    favIcon = do
-      H.unsafeByteString . encodeUtf8 $
-        [text|
-        <link href="/ema.svg" rel="icon" />
-        |]
 
-lookupTitleForgiving :: Sources -> SourcePath -> Text
+lookupTitleForgiving :: MarkdownSources -> MarkdownPath -> Text
 lookupTitleForgiving srcs spath =
-  fromMaybe (sourcePathFileBase spath) $ do
+  fromMaybe (markdownPathFileBase spath) $ do
     doc <- Map.lookup spath $ untag srcs
     is <- getPandocH1 doc
     pure $ plainify is
 
-renderBreadcrumbs :: Sources -> SourcePath -> H.Html
+renderBreadcrumbs :: MarkdownSources -> MarkdownPath -> H.Html
 renderBreadcrumbs srcs spath = do
-  whenNotNull (init $ sourcePathInits spath) $ \(toList -> crumbs) ->
+  whenNotNull (init $ markdownPathInits spath) $ \(toList -> crumbs) ->
     H.div ! A.class_ "w-full text-gray-600 mt-4" $ do
       H.div ! A.class_ "flex justify-center" $ do
         H.div ! A.class_ "w-full bg-white py-2 rounded" $ do

src/Ema/Server.hs

@@ -87,8 +87,8 @@ runServerWithWebSocketHotReload port model render = do
                 foldl1' (Static.<|>) $ Static.hasPrefix <$> assets
            in Static.staticPolicy assetPolicy
     httpApp req f = do
-      v <- LVar.get model
-      let mr = routeFromPathInfo v (Wai.pathInfo req)
+      modelVal <- LVar.get model
+      let mr = routeFromPathInfo modelVal (Wai.pathInfo req)
       putStrLn $ "[http] " <> show mr
       (status, v) <- case mr of
         Nothing ->