+
+Ema is a next-gen **Haskell** library for building [jamstack-style](https://jamstack.org/) static sites, with fast hot reload. See [ema.srid.ca](https://ema.srid.ca/) for further information.
+
+The simplest Ema app looks like this:
+
+```haskell
+main :: IO ()
+main = do
+ let name :: Text = "Ema"
+ runEmaPure $ \_ ->
+ encodeUtf8 $ "Hello, from " <> name
+```
+
+## Hacking
+
+Run `bin/run` (or Ctrl+Shift+B in VSCode). This runs the documentation example; modify `./.ghcid` to run a different example, such as the clock example - which updates every second, demonstrating hot reload.
diff --git a/docs/Main.hs b/docs/Main.hs
new file mode 100644
--- /dev/null
+++ b/docs/Main.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import qualified Ema.Example.Ex03_Documentation as Doc
+
+main :: IO ()
+main = Doc.main
diff --git a/ema.cabal b/ema.cabal
new file mode 100644
--- /dev/null
+++ b/ema.cabal
@@ -0,0 +1,133 @@
+cabal-version: 2.4
+name: ema
+version: 0.1.0.0
+license: AGPL-3.0-only
+copyright: 2021 Sridhar Ratnakumar
+maintainer: srid@srid.ca
+author: Sridhar Ratnakumar
+category: Web
+synopsis: Static site generator library with hot reload
+bug-reports: https://github.com/srid/ema/issues
+homepage: https://ema.srid.ca/
+description:
+ Ema is a next-gen Haskell library for building jamstack-style static sites.
+ Ema sites are change-aware; in addition to good ol’ static site generation,
+ it provides a live server supporting fast hot-reload in the browser on code
+ or data change.
+
+extra-source-files:
+ CHANGELOG.md
+ LICENSE
+ README.md
+
+flag with-examples
+ description: Include examples and their dependencies
+ default: True
+
+flag with-helpers
+ description: Include helper modules based on blaze-html
+ default: True
+
+library
+ -- Modules included in this executable, other than Main.
+ -- other-modules:
+
+ -- LANGUAGE extensions used by modules in this package.
+ -- other-extensions:
+ build-depends:
+ , aeson
+ , async
+ , base >=4.13.0.0 && <=4.17.0.0
+ , containers
+ , data-default
+ , directory
+ , filepath
+ , http-types
+ , lvar
+ , monad-logger
+ , monad-logger-extras
+ , neat-interpolation
+ , optparse-applicative
+ , relude
+ , safe-exceptions
+ , stm
+ , text
+ , unliftio
+ , wai
+ , wai-middleware-static
+ , wai-websockets
+ , warp
+ , websockets
+
+ if (flag(with-helpers) || flag(with-examples))
+ build-depends:
+ , blaze-html
+ , blaze-markup
+ , filepattern
+ , fsnotify
+
+ if flag(with-examples)
+ build-depends:
+ , commonmark
+ , commonmark-extensions
+ , commonmark-pandoc
+ , pandoc-types
+ , profunctors
+ , shower
+ , tagged
+ , time
+
+ mixins:
+ base hiding (Prelude),
+ relude (Relude as Prelude, Relude.Container.One),
+ relude
+
+ ghc-options:
+ -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns
+
+ default-extensions:
+ FlexibleContexts
+ FlexibleInstances
+ KindSignatures
+ LambdaCase
+ MultiParamTypeClasses
+ MultiWayIf
+ OverloadedStrings
+ ScopedTypeVariables
+ TupleSections
+ ViewPatterns
+
+ exposed-modules:
+ Ema
+ Ema.CLI
+
+ if (flag(with-helpers) || flag(with-examples))
+ exposed-modules:
+ Ema.Helper.FileSystem
+ Ema.Helper.Tailwind
+
+ other-modules:
+ Ema.App
+ Ema.Class
+ Ema.Generate
+ Ema.Route
+ Ema.Route.Slug
+ Ema.Route.UrlStrategy
+ Ema.Server
+
+ if flag(with-examples)
+ exposed-modules:
+ Ema.Example.Ex01_HelloWorld
+ Ema.Example.Ex02_Clock
+ Ema.Example.Ex03_Documentation
+
+ hs-source-dirs: src
+ default-language: Haskell2010
+
+executable ema-docs
+ hs-source-dirs: docs
+ default-language: Haskell2010
+ main-is: Main.hs
+ build-depends:
+ , base
+ , ema
diff --git a/src/Ema.hs b/src/Ema.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Ema
+ ( module X,
+ )
+where
+
+import Ema.App as X
+import Ema.Class as X
+import Ema.Route as X
diff --git a/src/Ema/App.hs b/src/Ema/App.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/App.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Ema.App
+ ( runEma,
+ runEmaPure,
+ runEmaWithCli,
+ MonadEma,
+ )
+where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (race_)
+import Control.Monad.Logger
+import Control.Monad.Logger.Extras
+import Data.LVar (LVar)
+import qualified Data.LVar as LVar
+import Ema.CLI (Action (..), Cli)
+import qualified Ema.CLI as CLI
+import Ema.Class (Ema (..), MonadEma)
+import qualified Ema.Generate as Generate
+import qualified Ema.Server as Server
+import System.Directory (getCurrentDirectory, withCurrentDirectory)
+import System.Environment (lookupEnv)
+
+-- | Pure version of @runEmaWith@ (i.e with no model).
+--
+-- Due to purity, there is no impure state, and thus no time-varying model.
+-- Neither is there a concept of route, as only a single route (index.html) is
+-- expected, whose HTML contents is specified as the only argument to this
+-- function.
+runEmaPure ::
+ -- | How to render a route
+ (CLI.Action -> LByteString) ->
+ IO ()
+runEmaPure render = do
+ runEma (\act () () -> render act) $ \model -> do
+ LVar.set model ()
+ liftIO $ threadDelay maxBound
+
+-- | Convenient version of @runEmaWith@ that takes initial model and an update
+-- function. You typically want to use this.
+--
+-- It uses @race_@ to properly clean up the update action when the ema thread
+-- exits, and vice-versa.
+runEma ::
+ forall model route.
+ (Ema model route, Show route) =>
+ -- | How to render a route, given the model
+ (CLI.Action -> model -> route -> 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. MonadEma m => LVar model -> m ()) ->
+ IO ()
+runEma render runModel = do
+ cli <- CLI.cliAction
+ runEmaWithCli cli render runModel
+
+-- | Like @runEma@ but takes the CLI action
+--
+-- Useful if you are handling CLI arguments yourself.
+runEmaWithCli ::
+ forall model route.
+ (Ema model route, Show route) =>
+ Cli ->
+ -- | How to render a route, given the model
+ (CLI.Action -> model -> route -> 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. MonadEma m => LVar model -> m ()) ->
+ IO ()
+runEmaWithCli cli render runModel = do
+ model <- LVar.empty
+ -- TODO: Allow library users to control logging levels
+ let logger = colorize logToStdout
+ withCurrentDirectory (CLI.workingDir cli) $ do
+ cwd <- getCurrentDirectory
+ flip runLoggerLoggingT logger $ do
+ logInfoN $ "Running Ema under: " <> toText cwd
+ logInfoN "Waiting for initial site model ..."
+ logInfoN " stuck here? set a model value using `LVar.set`"
+ race_
+ (flip runLoggerLoggingT logger $ runModel model)
+ (flip runLoggerLoggingT logger $ runEmaWithCliInCwd (CLI.action cli) model render)
+
+-- | Run Ema live dev server
+runEmaWithCliInCwd ::
+ forall model route m.
+ (MonadEma m, Ema model route, Show route) =>
+ -- | CLI arguments
+ CLI.Action ->
+ -- | Your site model type, as a @LVar@ in order to support modifications over
+ -- time (for hot-reload).
+ --
+ -- 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 ->
+ -- | 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.
+ (Action -> model -> route -> LByteString) ->
+ m ()
+runEmaWithCliInCwd cliAction model render = do
+ case cliAction of
+ Generate dest -> do
+ val <- LVar.get model
+ Generate.generate dest val (render cliAction)
+ Run -> do
+ void $ LVar.get model
+ port <- liftIO $ fromMaybe 8000 . (readMaybe @Int =<<) <$> lookupEnv "PORT"
+ Server.runServerWithWebSocketHotReload port model (render cliAction)
diff --git a/src/Ema/CLI.hs b/src/Ema/CLI.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/CLI.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Ema.CLI where
+
+import Options.Applicative hiding (action)
+
+data Cli = Cli
+ { workingDir :: FilePath,
+ action :: Action
+ }
+ deriving (Eq, Show)
+
+data Action
+ = Generate FilePath
+ | Run
+ deriving (Eq, Show)
+
+cliParser :: Parser Cli
+cliParser = do
+ workingDir <-
+ option
+ str
+ ( short 'C' <> metavar "PATH" <> value "."
+ <> help "Run as if ema was started in PATH instead of the current working directory."
+ )
+ action <-
+ subparser
+ (command "gen" (info generate (progDesc "Generate static HTML files")))
+ <|> pure Run
+ pure Cli {..}
+ where
+ generate :: Parser Action
+ generate =
+ Generate <$> argument str (metavar "DEST...")
+
+cliAction :: IO Cli
+cliAction = do
+ execParser opts
+ where
+ opts =
+ info
+ (cliParser <**> helper)
+ ( fullDesc
+ <> progDesc "Ema - static site generator"
+ <> header "Ema"
+ )
diff --git a/src/Ema/Class.hs b/src/Ema/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Class.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# 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 model route | route -> model where
+ -- How to convert URLs to/from routes
+ encodeRoute :: route -> [Slug]
+ decodeRoute :: [Slug] -> Maybe route
+
+ -- | Routes to use when generating the static site
+ --
+ -- This is never used by the dev server.
+ staticRoutes :: model -> [route]
+
+ -- | List of (top-level) filepaths to serve as static assets
+ --
+ -- These will be copied over as-is during static site generation
+ staticAssets :: Proxy route -> [FilePath]
+ staticAssets Proxy = mempty
+
+-- | 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
+ staticRoutes () = one ()
diff --git a/src/Ema/Example/Ex01_HelloWorld.hs b/src/Ema/Example/Ex01_HelloWorld.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex01_HelloWorld.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TypeApplications #-}
+
+-- | The simplest Ema site possible.
+--
+-- A site with one route (index) that displays content generated from pure
+-- values.
+module Ema.Example.Ex01_HelloWorld where
+
+import Ema (runEmaPure)
+
+main :: IO ()
+main = do
+ let speaker :: Text = "Ema"
+ runEmaPure $ \_ ->
+ encodeUtf8 $ "Hello, from " <> speaker
diff --git a/src/Ema/Example/Ex02_Clock.hs b/src/Ema/Example/Ex02_Clock.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex02_Clock.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE TypeApplications #-}
+{-# 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
+-- generated HTML is automatically updated on the browser. This is only a demo;
+-- usually we render HTML based on files on disk or something accessible outside
+-- of the browser. More advanced examples will demonstrate that.
+module Ema.Example.Ex02_Clock where
+
+import Control.Concurrent (threadDelay)
+import qualified Data.LVar as LVar
+import Data.List ((!!))
+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
+import Ema (Ema (..), routeUrl, runEma)
+import qualified Ema.CLI
+import qualified Ema.Helper.Tailwind as Tailwind
+import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+
+data Route
+ = Index
+ | OnlyTime
+ deriving (Show, Enum, Bounded)
+
+instance Ema UTCTime Route where
+ encodeRoute = \case
+ Index -> mempty
+ OnlyTime -> one "time"
+ decodeRoute = \case
+ [] -> Just Index
+ ["time"] -> Just OnlyTime
+ _ -> Nothing
+ staticRoutes _ =
+ [minBound .. maxBound]
+
+main :: IO ()
+main = do
+ runEma render $ \model ->
+ forever $ do
+ LVar.set model =<< liftIO getCurrentTime
+ liftIO $ threadDelay $ 1 * 1000000
+
+render :: Ema.CLI.Action -> UTCTime -> Route -> LByteString
+render emaAction now r =
+ Tailwind.layout emaAction (H.title "Clock") $
+ H.div ! A.class_ "container mx-auto" $ do
+ H.div ! A.class_ "border-t-1 p-2 tex{-# OPTIONS_GHC -fno-warn-orphans #-}t-center" $ do
+ "The current time is: "
+ H.pre ! A.class_ "text-6xl font-bold mt-2" $ do
+ H.span ! A.class_ ("text-" <> randomColor now <> "-500") $ do
+ let fmt = case r of
+ Index -> "%Y/%m/%d %H:%M:%S"
+ OnlyTime -> "%H:%M:%S"
+ H.toMarkup $ formatTime defaultTimeLocale fmt now
+ H.div ! A.class_ "mt-4 text-center" $ do
+ case r of
+ Index -> do
+ routeElem OnlyTime "Hide day?"
+ OnlyTime -> do
+ routeElem Index "Show day?"
+ where
+ routeElem r' w =
+ H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r' $ w
+ routeHref r' =
+ A.href (fromString . toString $ routeUrl r')
+ randomColor t =
+ let epochSecs = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" t
+ colors = ["green", "gray", "purple", "red", "blue", "yellow", "black", "pink"]
+ in colors !! mod epochSecs (length colors)
diff --git a/src/Ema/Example/Ex03_Documentation.hs b/src/Ema/Example/Ex03_Documentation.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex03_Documentation.hs
@@ -0,0 +1,471 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | An advanced example demonstrating how to build documentation sites.
+--
+-- This "example" is actually used to build Ema's documentation site itself. It
+-- is a work in progress currently.
+module Ema.Example.Ex03_Documentation where
+
+import qualified Commonmark as CM
+import qualified Commonmark.Extensions as CE
+import qualified Commonmark.Pandoc as CP
+import Control.Exception (throw)
+import Control.Monad.Logger
+import qualified Data.LVar as LVar
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Profunctor (dimap)
+import Data.Tagged (Tagged (Tagged), untag)
+import qualified Data.Text as T
+import Ema (Ema (..), Slug (unSlug), routeUrl, runEma)
+import qualified Ema.CLI
+import qualified Ema.Helper.FileSystem as FileSystem
+import qualified Ema.Helper.Tailwind as Tailwind
+import NeatInterpolation (text)
+import System.FilePath (splitExtension, splitPath)
+import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5 as H
+import qualified Text.Blaze.Html5.Attributes as A
+import qualified Text.Pandoc.Builder as B
+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 MarkdownPath = Tagged "MarkdownPath" (NonEmpty Text)
+
+indexMarkdownPath :: MarkdownPath
+indexMarkdownPath = Tagged $ "index" :| []
+
+mkMarkdownPath :: FilePath -> Maybe MarkdownPath
+mkMarkdownPath = \case
+ (splitExtension -> (fp, ".md")) ->
+ let slugs = T.dropWhileEnd (== '/') . toText <$> splitPath fp
+ in Tagged <$> nonEmpty slugs
+ _ ->
+ Nothing
+
+markdownPathFileBase :: MarkdownPath -> Text
+markdownPathFileBase (Tagged slugs) =
+ head $ NE.reverse slugs
+
+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 -> [MarkdownPath]
+ go x (y :| ys') =
+ let this = Tagged (x <> one y)
+ in case nonEmpty ys' of
+ Nothing ->
+ one this
+ Just ys ->
+ this : go (untag this) ys
+
+type MarkdownSources = Tagged "MarkdownSources" (Map MarkdownPath Pandoc)
+
+instance Ema MarkdownSources MarkdownPath where
+ encodeRoute = \case
+ Tagged ("index" :| []) -> mempty
+ Tagged paths -> toList . fmap (fromString . toString) $ paths
+ decodeRoute = \case
+ (nonEmpty -> Nothing) ->
+ pure $ Tagged $ one "index"
+ (nonEmpty -> Just slugs) -> do
+ let parts = toText . unSlug <$> slugs
+ -- Heuristic to let requests to static files (eg: favicon.ico) to pass through
+ guard $ not (any (T.isInfixOf ".") parts)
+ pure $ Tagged parts
+ staticRoutes (Map.keys . untag -> spaths) =
+ spaths
+ staticAssets _ =
+ ["manifest.json", "ema.svg"]
+
+log :: MonadLogger m => Text -> m ()
+log = logInfoNS "Ex03_Documentation"
+
+main :: IO ()
+main =
+ runEma render $ \model -> do
+ LVar.set model =<< do
+ mdFiles <- FileSystem.filesMatching "." ["**/*.md"]
+ forM mdFiles readSource
+ <&> Tagged . Map.fromList . catMaybes
+ FileSystem.onChange "." $ \fp -> \case
+ FileSystem.Update ->
+ whenJustM (readSource fp) $ \(spath, s) -> do
+ log $ "Update: " <> show spath
+ LVar.modify model $ Tagged . Map.insert spath s . untag
+ FileSystem.Delete ->
+ whenJust (mkMarkdownPath fp) $ \spath -> do
+ log $ "Delete: " <> show spath
+ LVar.modify model $ Tagged . Map.delete spath . untag
+ where
+ readSource :: (MonadIO m, MonadLogger m) => FilePath -> m (Maybe (MarkdownPath, Pandoc))
+ readSource fp =
+ runMaybeT $ do
+ spath :: MarkdownPath <- MaybeT $ pure $ mkMarkdownPath fp
+ log $ "Reading " <> toText fp
+ s <- readFileText fp
+ pure (spath, parseMarkdown s)
+
+newtype BadRoute = BadRoute MarkdownPath
+ deriving (Show, Exception)
+
+render :: Ema.CLI.Action -> MarkdownSources -> MarkdownPath -> LByteString
+render emaAction srcs spath = do
+ case Map.lookup spath (untag srcs) of
+ Nothing -> throw $ BadRoute spath
+ Just doc -> 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 routeTitle == siteTitle then siteTitle else routeTitle <> " – " <> siteTitle
+ H.meta ! A.name "description" ! A.content "Ema static site generator (Jamstack) in Haskell"
+ favIcon
+ -- 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 == indexMarkdownPath) prismJs
+ where
+ prismJs = do
+ H.unsafeByteString . encodeUtf8 $
+ [text|
+
+
+ |]
+ favIcon = do
+ H.unsafeByteString . encodeUtf8 $
+ [text|
+
+ |]
+
+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: "
+ "Documentation is still being written"
+ H.div ! A.class_ "container mx-auto xl:max-w-screen-lg" $ do
+ H.div ! A.class_ "px-2" $ do
+ renderBreadcrumbs srcs spath
+ renderPandoc $
+ doc
+ & applyClassLibrary (\c -> fromMaybe c $ Map.lookup c emaMarkdownStyleLibrary)
+ & rewriteLinks
+ -- Rewrite .md links to @MarkdownPath@
+ ( \url -> fromMaybe url $ do
+ guard $ not $ "://" `T.isInfixOf` url
+ target <- mkMarkdownPath $ toString url
+ -- Check that .md links are not broken
+ if Map.member target (untag srcs)
+ then pure $ routeUrl target
+ else throw $ BadRoute target
+ )
+ H.footer ! A.class_ "mt-8 text-center text-gray-500" $ do
+ "Powered by "
+ H.a ! A.class_ "font-bold" ! A.target "blank" ! A.href "https://github.com/srid/ema" $ "Ema"
+ where
+ emaMarkdownStyleLibrary =
+ Map.fromList
+ [ ("feature", "flex justify-center items-center text-center shadow-lg p-2 m-2 w-32 h-16 lg:w-auto rounded border-2 border-gray-400 bg-pink-100 text-base font-bold hover:bg-pink-200 hover:border-black"),
+ ("avatar", "float-right w-32 h-32"),
+ -- List item specifc styles
+ ("item-intro", "text-gray-500"),
+ -- Styling the last line in series posts
+ ("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")
+ ]
+
+lookupTitleForgiving :: MarkdownSources -> MarkdownPath -> Text
+lookupTitleForgiving srcs spath =
+ fromMaybe (markdownPathFileBase spath) $ do
+ doc <- Map.lookup spath $ untag srcs
+ is <- getPandocH1 doc
+ pure $ plainify is
+
+renderBreadcrumbs :: MarkdownSources -> MarkdownPath -> H.Html
+renderBreadcrumbs srcs spath = do
+ 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
+ H.ul ! A.class_ "flex text-gray-500 text-sm lg:text-base" $ do
+ forM_ crumbs $ \crumb ->
+ H.li ! A.class_ "inline-flex items-center" $ do
+ H.a ! A.class_ "px-1 font-bold bg-pink-500 text-gray-50 rounded"
+ ! routeHref crumb
+ $ H.text $ lookupTitleForgiving srcs crumb
+ rightArrow
+ H.li ! A.class_ "inline-flex items-center text-gray-600" $ do
+ H.a $ H.text $ lookupTitleForgiving srcs spath
+ where
+ rightArrow =
+ H.unsafeByteString $
+ encodeUtf8
+ [text|
+
+ |]
+
+routeHref :: Ema a r => r -> H.Attribute
+routeHref r' =
+ A.href (fromString . toString $ routeUrl r')
+
+-- Pandoc transformer
+
+rewriteLinks :: (Text -> Text) -> Pandoc -> Pandoc
+rewriteLinks f =
+ W.walk $ \case
+ B.Link attr is (url, title) ->
+ B.Link attr is (f url, title)
+ x -> x
+
+applyClassLibrary :: (Text -> Text) -> Pandoc -> Pandoc
+applyClassLibrary f =
+ walkBlocks . walkInlines
+ where
+ walkBlocks = W.walk $ \case
+ B.Div attr bs ->
+ B.Div (g attr) bs
+ x -> x
+ walkInlines = W.walk $ \case
+ B.Span attr is ->
+ B.Span (g attr) is
+ x -> x
+ g (id', cls, attr) =
+ (id', withPackedClass f cls, attr)
+ withPackedClass :: (Text -> Text) -> [Text] -> [Text]
+ withPackedClass =
+ dimap (T.intercalate " ") (T.splitOn " ")
+
+-- Pandoc renderer
+--
+-- Note that we hardcode tailwind classes, because pandoc AST is not flexible
+-- enough to provide attrs for all inlines/blocks. So we can't rely on Walk to
+-- transform it.
+
+renderPandoc :: Pandoc -> H.Html
+renderPandoc (Pandoc _meta blocks) =
+ mapM_ rpBlock blocks
+
+rpBlock :: B.Block -> H.Html
+rpBlock = \case
+ B.Plain is ->
+ mapM_ rpInline is
+ B.Para is ->
+ H.p ! A.class_ "my-2" $ mapM_ rpInline is
+ B.LineBlock iss ->
+ forM_ iss $ \is ->
+ mapM_ rpInline is >> "\n"
+ B.CodeBlock (id', classes, attrs) s ->
+ -- Prism friendly classes
+ let classes' = flip concatMap classes $ \cls -> [cls, "language-" <> cls]
+ in H.pre ! rpAttr (id', classes', attrs) $ H.code ! rpAttr ("", classes', []) $ H.text s
+ B.RawBlock _ _ ->
+ pure ()
+ B.BlockQuote bs ->
+ H.blockquote $ mapM_ rpBlock bs
+ B.OrderedList _ bss ->
+ H.ol ! A.class_ listStyle $
+ forM_ bss $ \bs ->
+ H.li ! A.class_ listItemStyle $ mapM_ rpBlock bs
+ B.BulletList bss ->
+ H.ul ! A.class_ (listStyle <> " list-disc") $
+ forM_ bss $ \bs ->
+ H.li ! A.class_ listItemStyle $ mapM_ rpBlock bs
+ B.DefinitionList defs ->
+ H.dl $
+ forM_ defs $ \(term, descList) -> do
+ mapM_ rpInline term
+ forM_ descList $ \desc ->
+ H.dd $ mapM_ rpBlock desc
+ B.Header level attr is ->
+ headerElem level ! rpAttr attr $ mapM_ rpInline is
+ B.HorizontalRule ->
+ H.hr
+ B.Table {} ->
+ throw Unsupported
+ B.Div attr bs ->
+ H.div ! rpAttr attr $ mapM_ rpBlock bs
+ B.Null ->
+ pure ()
+ where
+ listStyle = "list-inside ml-2"
+ listItemStyle = "text-xl py-1.5 lg:py-0 lg:text-base"
+
+headerElem :: Int -> H.Html -> H.Html
+headerElem = \case
+ 1 -> H.h1 ! A.class_ ("text-6xl " <> my <> " text-center py-2")
+ 2 -> H.h2 ! A.class_ ("text-5xl " <> my)
+ 3 -> H.h3 ! A.class_ ("text-4xl " <> my)
+ 4 -> H.h4 ! A.class_ ("text-3xl " <> my)
+ 5 -> H.h5 ! A.class_ ("text-2xl " <> my)
+ 6 -> H.h6 ! A.class_ ("text-xl " <> my)
+ _ -> error "Invalid pandoc header level"
+ where
+ my = "my-2"
+
+rpInline :: B.Inline -> H.Html
+rpInline = \case
+ B.Str s -> H.toHtml s
+ B.Emph is ->
+ H.em $ mapM_ rpInline is
+ B.Strong is ->
+ H.strong $ mapM_ rpInline is
+ B.Underline is ->
+ H.u $ mapM_ rpInline is
+ B.Strikeout is ->
+ -- FIXME: Should use Ema App threw an exception
" + <> show @Text err + <> "
Once you fix your code this page will automatically update." + routeFromPathInfo = + decodeRoute @model . fmap (fromString . toString) + -- TODO: It would be good have this also get us the stack trace. + unsafeCatch :: Exception e => a -> (e -> a) -> a + unsafeCatch x f = unsafePerformIO $ catch (seq x $ pure x) (pure . f) + +-- | Return the equivalent of WAI's @pathInfo@, from the raw path string +-- (`document.location.pathname`) the browser sends us. +pathInfoFromWsMsg :: Text -> [Text] +pathInfoFromWsMsg = + filter (/= "") . T.splitOn "/" . T.drop 1 + +-- Browser-side JavaScript code for interacting with the Haskell server +wsClientShim :: LByteString +wsClientShim = + encodeUtf8 + [text| + + + + |] + +emaStatusHtml :: LByteString +emaStatusHtml = + encodeUtf8 + [text| +
+ |]