ema 0.6.0.0 → 0.8.0.0

raw patch · 48 files changed

+3391/−807 lines, 48 filesdep +emadep +file-embeddep +fsnotifydep ~basedep ~reludePVP ok

version bump matches the API change (PVP)

Dependencies added: ema, file-embed, fsnotify, generic-optics, generics-sop, mtl, optics-core, pandoc, pandoc-types, raw-strings-qq, sop-core, template-haskell, unionmount

Dependency ranges changed: base, relude

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−0
• README.md +12/−2
• ema.cabal +133/−55
• src/Ema.hs +15/−9
• src/Ema/App.hs +81/−118
• src/Ema/Asset.hs +13/−3
• src/Ema/CLI.hs +66/−14
• src/Ema/Class.hs +0/−29
• src/Ema/Dynamic.hs +62/−0
• src/Ema/Example/Common.hs +17/−4
• src/Ema/Example/Ex00_Hello.hs +21/−0
• src/Ema/Example/Ex01_Basic.hs +44/−0
• src/Ema/Example/Ex01_HelloWorld.hs +0/−13
• src/Ema/Example/Ex02_Basic.hs +0/−56
• src/Ema/Example/Ex02_Clock.hs +89/−0
• src/Ema/Example/Ex03_Clock.hs +0/−75
• src/Ema/Example/Ex03_Store.hs +184/−0
• src/Ema/Example/Ex04_Multi.hs +105/−0
• src/Ema/Example/Ex05_MultiRoute.hs +57/−0
• src/Ema/Generate.hs +122/−71
• src/Ema/Route.hs +0/−62
• src/Ema/Route/Class.hs +32/−0
• src/Ema/Route/Generic.hs +164/−0
• src/Ema/Route/Generic/Example.hs +159/−0
• src/Ema/Route/Generic/RGeneric.hs +99/−0
• src/Ema/Route/Generic/SubModel.hs +42/−0
• src/Ema/Route/Generic/SubRoute.hs +113/−0
• src/Ema/Route/Generic/TH.hs +44/−0
• src/Ema/Route/Generic/Verification.hs +57/−0
• src/Ema/Route/Lib/Extra/PandocRoute.hs +197/−0
• src/Ema/Route/Lib/Extra/SlugRoute.hs +40/−0
• src/Ema/Route/Lib/Extra/StaticRoute.hs +111/−0
• src/Ema/Route/Lib/File.hs +28/−0
• src/Ema/Route/Lib/Folder.hs +48/−0
• src/Ema/Route/Lib/Multi.hs +106/−0
• src/Ema/Route/Prism.hs +56/−0
• src/Ema/Route/Prism/Check.hs +93/−0
• src/Ema/Route/Prism/Type.hs +46/−0
• src/Ema/Route/Url.hs +77/−0
• src/Ema/Server.hs +132/−296
• src/Ema/Site.hs +74/−0
• src/GHC/TypeLits/Extra.hs +15/−0
• src/GHC/TypeLits/Extra/Symbol.hs +63/−0
• test/type-errors/Deriving.hs +243/−0
• test/type-errors/Spec.hs +5/−0
• www/ema-error.html +16/−0
• www/ema-indicator.html +103/−0
• www/ema-shim.js +186/−0

@@ -1,5 +1,26 @@ # Revision history for ema +## 0.8.0.0 (2022-08-19)++This releases brings a significant rewrite of Ema. If you choose to upgrade your apps from 0.6, see https://ema.srid.ca/start/upgrade for guidance.++- GHC 9.x support+- Better handling of URL anchors (#83; #87)+- `routeUrl` uses `UrlDirect` by default. Use `routeUrlWith` if you want to change that.+- Ema status indicator now works independently (requires no Tailwind)+- Multisite rewrite (Ema has been mostly rewritten for better composability) ([\#82](https://github.com/EmaApps/ema/pull/81))+  - Represent route encoding using `Prism'` from optics-core; add `IsRoute` class to define them.+    - Optional generic deriving of route prisms, so you do not have to hand-write them.+    - Automatic isomorphism checks ensures that encoding and decoding are isomorphic (route prisms are lawful)+  - Composable Ema apps +    - There are two ways of composing Ema apps. Using heterogenous lists (see `Ema.Route.Lib.Multi`), or by defining a top-level route type (see `Ex04_Multi.hs`).+  - Replace `LVar` with `Dynamic`.+    - Ema still uses `LVar` internally (for live server updates), but on the user-side one only needs to provide a `Dynamic` which is a tuple of initial value and an updating function. The [unionmount](https://github.com/srid/unionmount/pull/1) library was changed to provide this tuple.+  - Add `EmaSite` typeclass to "connect them all"+    - `SiteArg`: Type of value to pass from the environment.+    - `siteInput`: Define the `Dynamic` model for the site.+    - `siteOutput`: Asset (eg: HTML) to produce for each route.+ ## 0.6.0.0 -- 2022-02-05  - Websocket API: Add `ema.switchRoute` to switch to other routes in live server.

@@ -3,7 +3,6 @@ <img width="10%" src="https://ema.srid.ca/favicon.svg">  [![Hackage](https://img.shields.io/hackage/v/ema.svg?logo=haskell)](https://hackage.haskell.org/package/ema)-[![FAIR](https://img.shields.io/badge/FAIR-pledge-blue)](https://www.fairforall.org/about/)  Ema is a next-gen **Haskell** library toolkit for building [jamstack-style](https://jamstack.org/) static sites, with fast hot reload. See [ema.srid.ca](https://ema.srid.ca/) for further information. @@ -11,8 +10,19 @@  ## Hacking -Run `bin/run` (or <kbd>Ctrl+Shift+B</kbd> in VSCode). This runs the clock example (which updates every second, only to demonstrate hot reload); modify `./.ghcid` to run a different example. +*NOTE: `flake.nix` uses GHC 9.2 which is not yet the default in `nixpkgs`, so you may want to use the [garnix cache](https://garnix.io/docs/caching) to avoid long compilation times.* +Run `bin/run`. This runs the Ex04_Multi example.++To run the docs, run `nix run github:EmaApps/emanote -- -L ./docs`.+ ## Getting Started  https://ema.srid.ca/start++## Discussion++To discuss the Ema project, [join Matrix][matrix] or post in [GitHub Discussions][ghdiscuss].++[matrix]: https://matrix.to/#/#ema:matrix.org+[ghdiscuss]: https://github.com/EmaApps/ema/discussions

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               ema-version:            0.6.0.0+version:            0.8.0.0 license:            AGPL-3.0-only copyright:          2021 Sridhar Ratnakumar maintainer:         srid@srid.ca@@ -20,11 +20,67 @@   LICENSE   README.md +data-dir:           www+data-files:+  ema-error.html+  ema-indicator.html+  ema-shim.js++-- This flag is enabled by default just so `bin/run` can work on macOS M1.+-- When disabling, ensure that macOS build doesn't break. flag with-examples   description: Include examples and their dependencies-  default:     False+  default:     True +flag with-extra+  description: Include non-core functionality+  default:     True++common extensions+  default-extensions:+    NoStarIsType+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    EmptyCase+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    ExplicitForAll+    FlexibleContexts+    FlexibleInstances+    GADTSyntax+    GeneralisedNewtypeDeriving+    ImportQualifiedPost+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NumericUnderscores+    OverloadedStrings+    PolyKinds+    PostfixOperators+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    StandaloneKindSignatures+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns+ library+  import:           extensions+   -- Modules included in this executable, other than Main.   -- other-modules: @@ -40,15 +96,22 @@     , dependent-sum     , dependent-sum-template     , directory+    , file-embed     , filepath     , filepattern+    , generic-optics+    , generics-sop     , http-types     , lvar     , monad-logger     , monad-logger-extras+    , mtl     , neat-interpolation+    , optics-core     , optparse-applicative-    , relude                  >=0.7      && <1.0+    , relude                  >=1.0+    , sop-core+    , template-haskell     , text     , unliftio     , url-slug@@ -62,8 +125,16 @@     build-depends:       , blaze-html       , blaze-markup+      , fsnotify       , time +  if flag(with-extra)+    build-depends:+      , pandoc+      , pandoc-types+      , time+      , unionmount+   mixins:     base hiding (Prelude),     relude (Relude as Prelude, Relude.Container.One),@@ -73,69 +144,76 @@     -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns     -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls     -fprint-explicit-foralls -fprint-explicit-kinds--  default-extensions:-    NoStarIsType-    BangPatterns-    ConstraintKinds-    DataKinds-    DeriveDataTypeable-    DeriveFoldable-    DeriveFunctor-    DeriveGeneric-    DeriveLift-    DeriveTraversable-    DerivingStrategies-    DerivingVia-    EmptyCase-    EmptyDataDecls-    EmptyDataDeriving-    ExistentialQuantification-    ExplicitForAll-    FlexibleContexts-    FlexibleInstances-    GADTSyntax-    GeneralisedNewtypeDeriving-    ImportQualifiedPost-    KindSignatures-    LambdaCase-    MultiParamTypeClasses-    MultiWayIf-    NumericUnderscores-    OverloadedStrings-    PolyKinds-    PostfixOperators-    RankNTypes-    ScopedTypeVariables-    StandaloneDeriving-    StandaloneKindSignatures-    TupleSections-    TypeApplications-    TypeFamilies-    TypeOperators-    ViewPatterns+    -fprint-potential-instances    exposed-modules:     Ema-    Ema.CLI--  other-modules:     Ema.App     Ema.Asset-    Ema.Class+    Ema.CLI+    Ema.Dynamic     Ema.Generate-    Ema.Route+    Ema.Route.Class+    Ema.Route.Generic+    Ema.Route.Generic.RGeneric+    Ema.Route.Generic.SubModel+    Ema.Route.Generic.SubRoute+    Ema.Route.Generic.TH+    Ema.Route.Generic.Verification+    Ema.Route.Lib.File+    Ema.Route.Lib.Folder+    Ema.Route.Lib.Multi+    Ema.Route.Prism+    Ema.Route.Prism.Check+    Ema.Route.Prism.Type+    Ema.Route.Url     Ema.Server+    Ema.Site -  if flag(with-examples)+  other-modules:    GHC.TypeLits.Extra++  if flag(with-extra)+    exposed-modules:+      Ema.Route.Lib.Extra.PandocRoute+      Ema.Route.Lib.Extra.SlugRoute+      Ema.Route.Lib.Extra.StaticRoute++  if impl(ghc >=9.2)+    other-modules: GHC.TypeLits.Extra.Symbol++  if (flag(with-examples) && impl(ghc >=9.2))     other-modules:       Ema.Example.Common-      Ema.Example.Ex01_HelloWorld-      Ema.Example.Ex02_Basic-      Ema.Example.Ex03_Clock+      Ema.Example.Ex00_Hello+      Ema.Example.Ex01_Basic+      Ema.Example.Ex02_Clock+      Ema.Example.Ex03_Store+      Ema.Example.Ex04_Multi+      Ema.Example.Ex05_MultiRoute+      Ema.Route.Generic.Example -  hs-source-dirs:     src-  default-language:   Haskell2010+  hs-source-dirs:   src+  default-language: Haskell2010++  if impl(ghc >=8.10)+    ghc-options: -Wunused-packages++test-suite test-type-errors+  import:           extensions+  build-depends:+    , base+    , ema+    , generics-sop+    , raw-strings-qq+    , template-haskell+    , text+    , url-slug++  other-modules:    Deriving+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test/type-errors+  default-language: Haskell2010    if impl(ghc >=8.10)     ghc-options: -Wunused-packages

@@ -1,12 +1,18 @@-module Ema-  ( module X,-  )-where+module Ema (+  module X,+) where  import Ema.App as X import Ema.Asset as X-import Ema.Class as X-import Ema.Route as X-import Ema.Server as X-  ( emaErrorHtmlResponse,-  )+import Ema.Dynamic as X+import Ema.Route.Class as X+import Ema.Route.Prism as X (fromPrism_, toPrism_)+import Ema.Route.Url as X (+  UrlStrategy (UrlDirect, UrlPretty),+  routeUrl,+  routeUrlWith,+ )+import Ema.Server as X (+  emaErrorHtmlResponse,+ )+import Ema.Site as X

@@ -1,130 +1,93 @@-module Ema.App-  ( runEma,-    runEmaPure,-    runEmaWithCli,-  )-where+{-# LANGUAGE AllowAmbiguousTypes #-} +module Ema.App (+  runSite,+  runSite_,+  runSiteWithCli,+) where+ import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (race)-import Control.Monad.Logger (MonadLoggerIO, logInfoN)-import Control.Monad.Logger.Extras-  ( colorize,-    logToStdout,-    runLoggerLoggingT,-  )+import Control.Concurrent.Async (race_)+import Control.Monad.Logger (LoggingT (runLoggingT), MonadLoggerIO (askLoggerIO), logInfoNS, logWarnNS)+import Control.Monad.Logger.Extras (runLoggerLoggingT) import Data.Dependent.Sum (DSum ((:=>)))-import Data.LVar (LVar) import Data.LVar qualified as LVar-import Data.Some-import Ema.Asset (Asset (AssetGenerated), Format (Html))-import Ema.CLI (Cli)+import Data.Some (Some (Some))+import Ema.CLI (getLogger) import Ema.CLI qualified as CLI-import Ema.Class (Ema)-import Ema.Generate qualified as Generate+import Ema.Dynamic (Dynamic (Dynamic))+import Ema.Generate (generateSiteFromModel)+import Ema.Route.Class (IsRoute (RouteModel)) import Ema.Server qualified as Server+import Ema.Site (EmaSite (SiteArg, siteInput), EmaStaticSite) import System.Directory (getCurrentDirectory)-import UnliftIO-  ( BufferMode (BlockBuffering, LineBuffering),-    MonadUnliftIO,-    hFlush,-    hSetBuffering,-  ) --- | 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-  (Some CLI.Action -> LByteString) ->-  IO ()-runEmaPure render = do-  void $-    runEma (\act () () -> AssetGenerated Html $ render act) $ \act model -> do-      LVar.set model ()-      when (CLI.isLiveServer act) $-        liftIO $ threadDelay maxBound+{- | Run the given Ema site, --- | 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 b.-  (Ema model route, Show route) =>-  -- | How to render a route, given the model-  (Some CLI.Action -> model -> route -> 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) ->-  IO (Either b (DSum CLI.Action Identity))-runEma render runModel = do+  Takes as argument the associated `SiteArg`.++  In generate mode, return the generated files.  In live-server mode, this+  function will never return.+-}+runSite ::+  forall r.+  (Show r, Eq r, EmaStaticSite r) =>+  -- | The input required to create the `Dynamic` of the `RouteModel`+  SiteArg r ->+  IO [FilePath]+runSite input = do   cli <- CLI.cliAction-  runEmaWithCli cli render runModel+  result <- snd <$> runSiteWithCli @r cli input+  case result of+    CLI.Run _ :=> Identity () ->+      flip runLoggerLoggingT (getLogger cli) $+        CLI.crash "ema" "Live server unexpectedly stopped"+    CLI.Generate _ :=> Identity fs ->+      pure fs --- | Like @runEma@ but takes the CLI action------ Useful if you are handling CLI arguments yourself.-runEmaWithCli ::-  forall model route b.-  (Ema model route, Show route) =>-  Cli ->-  -- | How to render a route, given the model-  (Some CLI.Action -> model -> route -> 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) ->-  IO (Either b (DSum CLI.Action Identity))-runEmaWithCli cli render runModel = do-  model <- LVar.empty-  -- TODO: Allow library users to control logging levels, or colors.-  let logger = colorize logToStdout-  flip runLoggerLoggingT logger $ do-    cwd <- liftIO getCurrentDirectory-    logInfoN $ "Launching Ema under: " <> toText cwd-    logInfoN "Waiting for initial model ..."-  race-    (flip runLoggerLoggingT logger $ runModel (CLI.action cli) model)-    (flip runLoggerLoggingT logger $ runEmaWithCliInCwd (CLI.action cli) model render)+-- | Like @runSite@ but discards the result+runSite_ :: forall r. (Show r, Eq r, EmaStaticSite r) => SiteArg r -> IO ()+runSite_ = void . runSite @r --- | Run Ema live dev server-runEmaWithCliInCwd ::-  forall model route m.-  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m, Ema model route, Show route) =>-  -- | CLI arguments-  Some 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.-  (Some CLI.Action -> model -> route -> Asset LByteString) ->-  m (DSum CLI.Action Identity)-runEmaWithCliInCwd cliAction model render = do-  val <- LVar.get model-  logInfoN "... initial model is now available."-  case cliAction of-    Some (CLI.Generate dest) -> do-      fs <--        withBlockBuffering $-          Generate.generate dest val (render cliAction)-      pure $ CLI.Generate dest :=> Identity fs-    Some (CLI.Run (host, port)) -> do-      Server.runServerWithWebSocketHotReload host port model (render cliAction)-      pure $ CLI.Run (host, port) :=> Identity ()-  where-    -- Temporarily use block buffering before calling an IO action that is-    -- known ahead to log rapidly, so as to not hamper serial processing speed.-    withBlockBuffering f =-      hSetBuffering stdout (BlockBuffering Nothing)-        *> f-        <* (hSetBuffering stdout LineBuffering >> hFlush stdout)+{- | Like @runSite@ but takes the CLI action. Also returns more information.++ Useful if you are handling the CLI arguments yourself.++ Use "void $ Ema.runSiteWithCli def ..." if you are running live-server only.+-}+runSiteWithCli ::+  forall r.+  (Show r, Eq r, EmaStaticSite r) =>+  CLI.Cli ->+  SiteArg r ->+  IO+    ( -- The initial model value.+      RouteModel r+    , DSum CLI.Action Identity+    )+runSiteWithCli cli siteArg = do+  flip runLoggerLoggingT (getLogger cli) $ do+    cwd <- liftIO getCurrentDirectory+    logInfoNS "ema" $ "Launching Ema under: " <> toText cwd+    Dynamic (model0 :: RouteModel r, cont) <- siteInput @r (CLI.action cli) siteArg+    case CLI.action cli of+      Some act@(CLI.Generate dest) -> do+        fs <- generateSiteFromModel @r dest model0+        pure (model0, act :=> Identity fs)+      Some act@(CLI.Run (host, mport)) -> do+        model <- LVar.empty+        LVar.set model model0+        logger <- askLoggerIO+        liftIO $+          race_+            ( flip runLoggingT logger $ do+                cont $ LVar.set model+                logWarnNS "ema" "modelPatcher exited; no more model updates!"+                -- We want to keep this thread alive, so that the server thread+                -- doesn't exit.+                liftIO $ threadDelay maxBound+            )+            ( flip runLoggingT logger $ do+                Server.runServerWithWebSocketHotReload @r host mport model+            )+        pure (model0, act :=> Identity ())

@@ -1,5 +1,10 @@-module Ema.Asset where+{-# LANGUAGE UndecidableInstances #-} +module Ema.Asset (+  Asset (..),+  Format (..),+) where+ -- | The type of assets that can be bundled in a static site. data Asset a   = -- | A file that is copied as-is from the source directory.@@ -9,7 +14,12 @@     AssetStatic FilePath   | -- | A file whose contents are generated at runtime by user code.     AssetGenerated Format a-  deriving stock (Eq, Show, Ord, Generic)+  deriving stock (Eq, Show, Ord, Functor, Generic) -data Format = Html | Other+-- | The format of a generated asset.+data Format+  = -- | Html assets are served by the live server with hot-reload+    Html+  | -- | Other assets are served by the live server as static files.+    Other   deriving stock (Eq, Show, Ord, Generic)

@@ -4,21 +4,37 @@  module Ema.CLI where +import Control.Monad.Logger (LogLevel (LevelDebug, LevelInfo), LogSource, MonadLoggerIO, logErrorNS)+import Control.Monad.Logger.Extras (+  Logger (Logger),+  colorize,+  logToStdout,+ ) import Data.Constraint.Extras.TH (deriveArgDict) import Data.Default (Default (def))-import Data.GADT.Compare.TH-  ( DeriveGCompare (deriveGCompare),-    DeriveGEQ (deriveGEq),-  )+import Data.GADT.Compare.TH (+  DeriveGCompare (deriveGCompare),+  DeriveGEQ (deriveGEq),+ ) import Data.GADT.Show.TH (DeriveGShow (deriveGShow)) import Data.Some (Some (..))-import Ema.Server (Host, Port)+import Network.Wai.Handler.Warp (Port) import Options.Applicative hiding (action) +-- | Host string to start the server on.+newtype Host = Host {unHost :: Text}+  deriving newtype (Eq, Show, Ord, IsString)++instance Default Host where+  def = "127.0.0.1"+ -- | CLI subcommand-data Action res where+data Action result where+  -- | Generate static files at the given output directory, returning the list+  -- of generated files.   Generate :: FilePath -> Action [FilePath]-  Run :: (Host, Port) -> Action ()+  -- | Run the live server+  Run :: (Host, Maybe Port) -> Action ()  $(deriveGEq ''Action) $(deriveGShow ''Action)@@ -29,30 +45,45 @@ isLiveServer (Some (Run _)) = True isLiveServer _ = False +-- | Ema's command-line interface options data Cli = Cli-  { action :: (Some Action)+  { action :: Some Action+  -- ^ The Ema action to run+  , verbose :: Bool+  -- ^ Logging verbosity   }   deriving stock (Eq, Show) +instance Default Cli where+  -- By default, run the live server on random port.+  def = Cli (Some (Run def)) False+ cliParser :: Parser Cli cliParser = do   action <-     subparser-      (command "gen" (info generate (progDesc "Generate static HTML files")))+      (command "gen" (info generate (progDesc "Generate static site")))       <|> subparser (command "run" (info run (progDesc "Run the live server")))       <|> pure (Some $ Run def)+  verbose <- switch (long "verbose" <> short 'v' <> help "Enable verbose logging")   pure Cli {..}   where     run :: Parser (Some Action)     run =-      Some . Run-        <$> ( (,) <$> strOption (long "host" <> short 'h' <> metavar "HOST" <> help "Host to bind to" <> value def)-                <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> help "Port to bind to" <> value def)-            )+      fmap (Some . Run) $ (,) <$> hostParser <*> optional portParser     generate :: Parser (Some Action)     generate =-      Some . Generate <$> argument str (metavar "DEST...")+      Some . Generate <$> argument str (metavar "DEST") +hostParser :: Parser Host+hostParser =+  strOption (long "host" <> short 'h' <> metavar "HOST" <> help "Host to bind to" <> value def)++portParser :: Parser Port+portParser =+  option auto (long "port" <> short 'p' <> metavar "PORT" <> help "Port to bind to")++-- | Parse Ema CLI arguments passed by the user. cliAction :: IO Cli cliAction = do   execParser opts@@ -64,3 +95,24 @@             <> progDesc "Ema - static site generator"             <> header "Ema"         )++getLogger :: Cli -> Logger+getLogger cli =+  logToStdout+    & colorize+    & allowLogLevelFrom (bool LevelInfo LevelDebug $ verbose cli)+  where+    allowLogLevelFrom :: LogLevel -> Logger -> Logger+    allowLogLevelFrom minLevel (Logger f) = Logger $ \loc src level msg ->+      if level >= minLevel+        then f loc src level msg+        else pass++{- | Crash the program with the given error message++ First log the message using Error level, and then exit using `fail`.+-}+crash :: (MonadLoggerIO m, MonadFail m) => LogSource -> Text -> m a+crash source msg = do+  logErrorNS source msg+  fail $ toString msg

@@ -1,29 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FunctionalDependencies #-}--module Ema.Class where---- | Enrich a model to work with Ema-class Ema model route | route -> model where-  -- | Get the filepath on disk corresponding to this route.-  encodeRoute :: model -> route -> FilePath--  -- | Decode a filepath on disk into a route.-  decodeRoute :: model -> FilePath -> Maybe route--  -- | 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 _ = [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 () () = []-  decodeRoute () = \case-    [] -> Just ()-    _ -> Nothing-  allRoutes () = one ()

@@ -0,0 +1,62 @@+module Ema.Dynamic (+  Dynamic (Dynamic),+) where++import Control.Monad.Logger (MonadLogger, logDebugNS)+import UnliftIO (MonadUnliftIO, race_)+import UnliftIO.Concurrent (threadDelay)++{- | A time-varying value of type `a`, changing under monad `m`.++  To create a `Dynamic`, supply the initial value along with a function that+  forever updates it using the given monadic update function.++ `Dynamic`'s can be composed using `Applicative`.+-}+newtype Dynamic m a+  = Dynamic+      ( -- Initial value+        a+      , -- Set a new value+        (a -> m ()) -> m ()+      )++instance Functor (Dynamic m) where+  fmap f (Dynamic (x0, xf)) =+    Dynamic+      ( f x0+      , \send -> xf $ send . f+      )++instance (MonadUnliftIO m, MonadLogger m) => Applicative (Dynamic m) where+  pure x = Dynamic (x, const pass)+  liftA2 f (Dynamic (x0, xf)) (Dynamic (y0, yf)) =+    Dynamic+      ( f x0 y0+      , \send -> do+          var <- newTVarIO (x0, y0)+          sendLock :: TMVar () <- newEmptyTMVarIO+          race_+            ( do+                xf $ \x -> do+                  atomically $ putTMVar sendLock ()+                  logDebugNS "ema.dyn.app" "left update"+                  send <=< atomically $ do+                    modifyTVar' var $ first (const x)+                    f x . snd <$> readTVar var+                  atomically $ takeTMVar sendLock+                logDebugNS "ema.dyn.app" "updater exited; keeping thread alive"+                threadDelay maxBound+            )+            ( do+                yf $ \y -> do+                  atomically $ putTMVar sendLock ()+                  logDebugNS "ema.dyn.app" "right update"+                  send <=< atomically $ do+                    modifyTVar' var $ second (const y)+                    (`f` y) . fst <$> readTVar var+                  atomically $ takeTMVar sendLock+                logDebugNS "ema.dyn.app" "updater exited; keeping thread alive"+                threadDelay maxBound+            )+      )

@@ -1,8 +1,10 @@-module Ema.Example.Common-  ( tailwindLayout,-  )-where+module Ema.Example.Common (+  tailwindLayout,+  watchDirForked,+) where +import Control.Concurrent (Chan, forkIO, newChan, threadDelay)+import System.FSNotify qualified as FSNotify import Text.Blaze.Html.Renderer.Utf8 qualified as RU import Text.Blaze.Html5 ((!)) import Text.Blaze.Html5 qualified as H@@ -35,3 +37,14 @@         ! A.href "https://unpkg.com/tailwindcss@2/dist/tailwind.min.css"         ! A.rel "stylesheet"         ! A.type_ "text/css"++-- Observe changes to a directory path, and return the `Chan` of its events.+watchDirForked :: FilePath -> IO (Chan FSNotify.Event)+watchDirForked path = do+  ch <- newChan+  -- FIXME: We should be using race_, not forkIO.+  void . forkIO $+    FSNotify.withManager $ \mgr -> do+      _stopListening <- FSNotify.watchDirChan mgr path (const True) ch+      threadDelay maxBound+  pure ch

@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Most trivial Ema program+module Ema.Example.Ex00_Hello where++import Ema++-- Let's newtype the unit route, because we have only one page to generate.+newtype Route = Route ()+  deriving newtype+    (Show, Eq, Ord, Generic, IsRoute)++instance EmaSite Route where+  siteInput _ _ =+    pure $ pure ()+  siteOutput _ _ _ =+    pure $ Ema.AssetGenerated Ema.Html "<b>Hello</b>, Ema"++main :: IO ()+main = void $ Ema.runSite @Route ()

@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- | A very simple site in three parts: route types, `main` and rendering implementation.+module Ema.Example.Ex01_Basic where++import Ema+import Ema.Example.Common (tailwindLayout)+import Ema.Route.Generic.TH+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++data Route+  = Route_Index+  | Route_About+  deriving stock (Show, Eq, Ord, Generic)++deriveGeneric ''Route+deriveIsRoute ''Route [t|'[]|]++instance EmaSite Route where+  siteInput _ _ = pure $ pure ()+  siteOutput rp () r =+    pure . Ema.AssetGenerated Ema.Html $+      tailwindLayout (H.title "Basic site" >> H.base ! A.href "/") $+        H.div ! A.class_ "container mx-auto mt-8 p-2" $ do+          H.h1 ! A.class_ "text-3xl font-bold" $ "Basic site"+          case r of+            Route_Index -> do+              "You are on the index page. "+              routeElem Route_About "Go to About"+            Route_About -> do+              routeElem Route_Index "Go to Index"+              ". You are on the about page. "+    where+      routeElem r' w = do+        H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w+      routeHref r' =+        A.href (fromString . toString $ Ema.routeUrl rp r')++main :: IO ()+main = void $ Ema.runSite @Route ()

@@ -1,13 +0,0 @@--- | 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 $ "<b>Hello</b>, from " <> speaker

@@ -1,56 +0,0 @@--- | A very simple site with two routes, and HTML rendered using Blaze DSL-module Ema.Example.Ex02_Basic where--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-import Text.Blaze.Html5.Attributes qualified as A--data Route-  = Index-  | About-  deriving stock (Show, Enum, Bounded)--newtype Model = Model {unModel :: Text}--instance Ema Model Route where-  encodeRoute _model =-    \case-      Index -> "index.html"-      About -> "about.html"-  decodeRoute _model = \case-    "index.html" -> Just Index-    "about.html" -> Just About-    _ -> Nothing--main :: IO ()-main = do-  void $-    Ema.runEma (\_act m -> Ema.AssetGenerated Ema.Html . render m) $ \act model -> do-      LVar.set model $ Model "Hello World. "-      when (CLI.isLiveServer act) $-        liftIO $ threadDelay maxBound--render :: Model -> Route -> LByteString-render model r =-  tailwindLayout (H.title "Basic site" >> H.base ! A.href "/") $-    H.div ! A.class_ "container mx-auto" $ do-      H.div ! A.class_ "mt-8 p-2 text-center" $ do-        case r of-          Index -> do-            H.toHtml (unModel model)-            "You are on the index page. "-            routeElem About "Go to About"-          About -> do-            "You are on the about page. "-            routeElem Index "Go to Index"-  where-    routeElem r' w =-      H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w-    routeHref r' =-      A.href (fromString . toString $ Ema.routeUrl model r')

@@ -0,0 +1,89 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++{- | 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 Control.Monad.Logger (logDebugNS, logInfoNS)+import Data.List ((!!))+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)+import Ema+import Ema.Example.Common (tailwindLayout)+import Ema.Route.Generic.TH+import Optics.Core (Prism')+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++type Model = UTCTime++data Route+  = Route_Index+  | Route_OnlyTime+  deriving stock (Show, Eq, Ord, Generic)++deriveGeneric ''Route+deriveIsRoute ''Route [t|'[WithModel Model]|]++instance EmaSite Route where+  type SiteArg Route = Int -- Delay between clock refresh+  siteInput _ timerDelay = do+    t0 <- liftIO getCurrentTime+    pure . Dynamic . (t0,) $ \setModel -> do+      logInfoNS "Ex02" "Starting clock..."+      forever $ do+        liftIO $ threadDelay timerDelay+        t <- liftIO getCurrentTime+        logDebugNS "Ex02" "Updating clock..."+        setModel t+  siteOutput rp m r =+    pure $ Ema.AssetGenerated Ema.Html $ render rp m r++main :: IO ()+main = do+  void $ Ema.runSite @Route delayNormal++delayNormal :: Int+delayNormal = 1000000 -- 1 second++delayFast :: Int+delayFast = 10000++render :: Prism' FilePath Route -> UTCTime -> Route -> LByteString+render rp now r =+  tailwindLayout (H.title "Clock" >> H.base ! A.href "/") $+    H.div ! A.class_ "container mx-auto" $ do+      H.div ! A.class_ "mt-8 p-2 text-center" $ do+        case r of+          Route_Index ->+            "The current date & time is: "+          Route_OnlyTime ->+            "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+                  Route_Index -> "%Y/%m/%d %H:%M:%S%Q"+                  Route_OnlyTime -> "%H:%M:%S"+            H.toMarkup $ formatTime defaultTimeLocale fmt now+      H.div ! A.class_ "mt-4 text-center" $ do+        case r of+          Route_Index -> do+            routeElem Route_OnlyTime "Hide day?"+          Route_OnlyTime -> do+            routeElem Route_Index "Show day?"+  where+    routeElem r' = H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r'+    routeHref r' =+      A.href (fromString . toString $ Ema.routeUrl rp 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)

@@ -1,75 +0,0 @@-{-# 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.Ex03_Clock where--import Control.Concurrent (threadDelay)-import Data.LVar qualified as LVar-import Data.List ((!!))-import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)-import Ema (Ema (..))-import Ema qualified-import Ema.Example.Common (tailwindLayout)-import Text.Blaze.Html5 ((!))-import Text.Blaze.Html5 qualified as H-import Text.Blaze.Html5.Attributes qualified as A--data Route-  = Index-  | OnlyTime-  deriving stock (Show, Enum, Bounded)--instance Ema UTCTime Route where-  encodeRoute _time = \case-    Index -> "index.html"-    OnlyTime -> "time.html"-  decodeRoute _time = \case-    "index.html" -> Just Index-    "time.html" -> Just OnlyTime-    _ -> Nothing--main :: IO ()-main = do-  void $-    Ema.runEma (\_act m -> Ema.AssetGenerated Ema.Html . render m) $ \_act model ->-      forever $ do-        -- logDebugNS "ex:clock" "Refreshing time"-        LVar.set model =<< liftIO getCurrentTime-        liftIO $ threadDelay 1000000--render :: UTCTime -> Route -> LByteString-render now r =-  tailwindLayout (H.title "Clock" >> H.base ! A.href "/") $-    H.div ! A.class_ "container mx-auto" $ do-      H.div ! A.class_ "mt-8 p-2 text-center" $ do-        case r of-          Index ->-            "The current date & time is: "-          OnlyTime ->-            "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 $ Ema.routeUrl now 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)

@@ -0,0 +1,184 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++{- | A simple web store for products++ Also demostrates both DerivingVia and TH based deriving of IsRoute.+-}+module Ema.Example.Ex03_Store where++import Control.Concurrent (readChan)+import Control.Exception (throwIO)+import Control.Monad.Logger (MonadLogger, logInfoNS)+import Data.Aeson (FromJSON, FromJSONKey, eitherDecodeFileStrict')+import Data.Map.Strict qualified as Map+import Ema+import Ema.Example.Common (tailwindLayout, watchDirForked)+import Ema.Route.Generic+import Ema.Route.Generic.TH (deriveGeneric, deriveIsRoute)+import Ema.Route.Prism+import Generics.SOP qualified as SOP+import Optics.Core (coercedTo, iso, prism', (%))+import System.FSNotify qualified as FSNotify+import System.FilePath (takeFileName, (</>))+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A+import Prelude hiding (Product)++data Model = Model+  { modelStoreName :: Text+  , modelProducts :: Map Slug Product+  , modelCategories :: Map Slug Category+  }+  deriving stock (Generic)+  deriving anyclass (FromJSON)++newtype Slug = Slug Text+  deriving newtype (Show, Eq, Ord, IsString, ToString, FromJSON, FromJSONKey)+  deriving stock (Generic)++newtype Product = Product {unProduct :: Text}+  deriving newtype (Show, Eq, Ord, IsString, ToString, FromJSON)++newtype Category = Category {unCategory :: Text}+  deriving newtype (Show, Eq, Ord, IsString, ToString, FromJSON)++data Route+  = Route_Index+  | Route_About+  | Route_Products ProductRoute+  | Route_Category CategoryRoute+  deriving stock (Show, Eq, Ord, Generic)++data ProductRoute+  = ProductRoute_Index+  | ProductRoute_Product Slug+  deriving stock (Show, Eq, Ord, Generic)++data CategoryRoute+  = CategoryRoute_Index+  | CategoryRoute_Category Slug+  deriving stock (Show, Eq, Ord, Generic)+  -- We can also do this using TemplateHaskell (see ProductRoute deriving below)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving+    (HasSubRoutes, HasSubModels, IsRoute)+    via ( GenericRoute+            CategoryRoute+            '[ WithModel (Map Slug Category)+             , WithSubRoutes+                '[ FileRoute "index.html"+                 , StringRoute Category Slug+                 ]+             ]+        )++-- | A route represented by a stringy type; associated with a foldable of the same as its model.+newtype StringRoute (a :: Type) r = StringRoute {unStringRoute :: r}+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)++instance (IsString r, ToString r, Eq r, Ord r) => IsRoute (StringRoute a r) where+  type RouteModel (StringRoute a r) = Map r a+  routePrism as =+    toPrism_ $+      htmlSuffixPrism+        % iso fromString toString+        % mapMemberPrism as+        % coercedTo+    where+      mapMemberPrism m =+        prism' id $ \r -> do pure r <* (guard $ r `Map.member` m)+  routeUniverse as = StringRoute <$> Map.keys as++deriveGeneric ''ProductRoute+deriveIsRoute+  ''ProductRoute+  [t|+    '[ WithModel (Map Slug Product)+     , WithSubRoutes+        '[ FileRoute "index.html"+         , StringRoute Product Slug+         ]+     ]+    |]++deriveGeneric ''Route+deriveIsRoute ''Route [t|'[WithModel Model]|]++main :: IO ()+main = void $ Ema.runSite @Route ()++instance EmaSite Route where+  siteInput _ () = do+    store0 <- readStoreFile+    pure . Dynamic . (store0,) $ \setModel -> do+      ch <- liftIO $ watchDirForked dataDir+      let loop = do+            log "Waiting for fs event ..."+            evt <- liftIO $ readChan ch+            log $ "Got fs event: " <> show evt+            when (takeFileName (FSNotify.eventPath evt) == "store.json") $ do+              setModel =<< readStoreFile+            loop+      loop+    where+      dataDir = "src/Ema/Example/Ex03_Store"+      readStoreFile :: (MonadIO m, MonadLogger m) => m Model+      readStoreFile = do+        log "Reading Store file"+        liftIO (eitherDecodeFileStrict' $ dataDir </> "store.json") >>= \case+          Left err -> liftIO $ throwIO $ StoreFileMalformed err+          Right store -> pure store+      log :: MonadLogger m => Text -> m ()+      log = logInfoNS "Ex03_Store"+  siteOutput rp (Model storeName ps cats) r =+    pure . Ema.AssetGenerated Ema.Html $+      tailwindLayout (H.title ("Store example: " <> H.toHtml storeName) >> H.base ! A.href "/") $+        H.div ! A.class_ "container mx-auto mt-8 p-2" $ do+          H.h1 ! A.class_ "text-3xl font-bold" $ H.toHtml storeName+          case r of+            Route_Index -> do+              "You are on the index page. "+              routeElem Route_About "Go to About"+              " or go to "+              routeElem (Route_Products ProductRoute_Index) "products"+              " or go to "+              routeElem (Route_Category CategoryRoute_Index) "categories"+            Route_About -> do+              routeElem Route_Index "Go to Index"+              ". You are on the about page. "+            Route_Products pr -> do+              H.h2 "Products"+              case pr of+                ProductRoute_Index -> do+                  H.p "List of products go here"+                  forM_ (Map.toList ps) $ \(k, Product p) -> do+                    H.li $ routeElem (Route_Products $ ProductRoute_Product k) $ H.toHtml p+                  routeElem Route_Index "Back to index"+                ProductRoute_Product name -> do+                  H.h3 ! A.class_ "p-2 border-2" $ show $ Map.lookup name ps+                  routeElem (Route_Products ProductRoute_Index) "Back to products"+            Route_Category cr -> do+              H.h2 "Categories"+              case cr of+                CategoryRoute_Index -> do+                  H.p "List of categories go here"+                  forM_ (Map.toList cats) $ \(k, Category c) -> do+                    H.li $ routeElem (Route_Category $ CategoryRoute_Category k) $ H.toHtml c+                  routeElem Route_Index "Back to index"+                CategoryRoute_Category name -> do+                  H.h3 ! A.class_ "p-2 border-2" $ show $ Map.lookup name cats+                  routeElem (Route_Category CategoryRoute_Index) "Back to categories"+    where+      routeElem r' w = do+        H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w+      routeHref r' =+        A.href (fromString . toString $ Ema.routeUrl rp r')++newtype StoreFileError = StoreFileMalformed String+  deriving stock (Show, Eq)+  deriving anyclass (Exception)

@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Demonstration of merging multiple sites++  For an alternative (easier) approach, see `Ex05_MultiRoute.hs`.+-}+module Ema.Example.Ex04_Multi where++import Data.Generics.Sum.Any (AsAny (_As))+import Ema+import Ema.Example.Common (tailwindLayout)+import Ema.Example.Ex00_Hello qualified as Ex00+import Ema.Example.Ex01_Basic qualified as Ex01+import Ema.Example.Ex02_Clock qualified as Ex02+import Ema.Example.Ex03_Store qualified as Ex03+import Ema.Route.Generic+import GHC.Generics qualified as GHC+import Generics.SOP (Generic, HasDatatypeInfo, I (I), NP (Nil, (:*)))+import Optics.Core (Prism', (%))+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A+import Prelude hiding (Generic)++data M = M+  { mClock :: Ex02.Model+  , mClockFast :: Ex02.Model+  , mStore :: Ex03.Model+  }+  deriving stock (GHC.Generic)++data R+  = R_Index+  | R_Hello Ex00.Route+  | R_Basic Ex01.Route+  | R_Clock Ex02.Route+  | R_ClockFast Ex02.Route+  | R_Store Ex03.Route+  deriving stock (Show, Ord, Eq, GHC.Generic)+  deriving anyclass (Generic, HasDatatypeInfo)+  deriving+    (HasSubRoutes, HasSubModels, IsRoute)+    via ( GenericRoute+            R+            '[ WithModel M+             , WithSubModels+                [ ()+                , ()+                , ()+                , -- You can refer to a record field by the field name+                  -- (We use `Proxy` only because heteregenous type+                  -- lists must be uni-kind).+                  Proxy "mClock"+                , Proxy "mClockFast"+                , -- Or by the field type.+                  -- Thanks to Data.Generics.Product.Any+                  Ex03.Model+                ]+             ]+        )++main :: IO ()+main = do+  void $ Ema.runSite @R ()++instance EmaSite R where+  siteInput cliAct () = do+    x1 :: Dynamic m Ex02.Model <- siteInput @Ex02.Route cliAct Ex02.delayNormal+    x2 :: Dynamic m Ex02.Model <- siteInput @Ex02.Route cliAct Ex02.delayFast+    x3 :: Dynamic m Ex03.Model <- siteInput @Ex03.Route cliAct ()+    pure $ liftA3 M x1 x2 x3+  siteOutput rp m = \case+    R_Index ->+      pure $ Ema.AssetGenerated Ema.Html $ renderIndex rp m+    R_Hello r ->+      siteOutput (rp % (_As @"R_Hello")) m2 r+    R_Basic r ->+      siteOutput (rp % (_As @"R_Basic")) m3 r+    R_Clock r ->+      siteOutput (rp % (_As @"R_Clock")) m4 r+    R_ClockFast r ->+      siteOutput (rp % (_As @"R_Clock")) m5 r+    R_Store r ->+      siteOutput (rp % (_As @"R_Store")) m6 r+    where+      I () :* I m2 :* I m3 :* I m4 :* I m5 :* I m6 :* Nil = subModels @R m++renderIndex :: Prism' FilePath R -> M -> LByteString+renderIndex rp m =+  tailwindLayout (H.title "Ex04_Multi" >> H.base ! A.href "/") $+    H.div ! A.class_ "container mx-auto text-center mt-8 p-2" $ do+      H.p "You can compose Ema sites. Here are three sites composed to produce one:"+      H.ul ! A.class_ "flex flex-col justify-center .items-center mt-4 space-y-4" $ do+        H.li $ routeElem (R_Hello $ Ex00.Route ()) "Ex00_Hello"+        H.li $ routeElem (R_Basic Ex01.Route_Index) "Ex01_Basic"+        H.li $ routeElem (R_Clock Ex02.Route_Index) "Ex02_Clock"+        H.li $ routeElem (R_ClockFast Ex02.Route_Index) "Ex02_ClockFast"+        H.li $ routeElem (R_Store Ex03.Route_Index) "Ex03_Store"+      H.p $ do+        "The current time is: "+        H.small $ show $ mClock m+  where+    routeElem r w = do+      H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! A.href (H.toValue $ routeUrl rp r) $ w

@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Demonstration of `MultiRoute`.+module Ema.Example.Ex05_MultiRoute where++import Ema+import Ema.Example.Common (tailwindLayout)+import Ema.Example.Ex00_Hello qualified as Ex00+import Ema.Example.Ex01_Basic qualified as Ex01+import Ema.Example.Ex02_Clock qualified as Ex02+import Ema.Example.Ex03_Store qualified as Ex03+import Ema.Route.Generic+import Ema.Route.Lib.Multi (MultiRoute)+import Generics.SOP (I (I), NP (Nil, (:*)))+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++type R =+  MultiRoute+    '[ TopRoute+     , FolderRoute "hello" Ex00.Route+     , FolderRoute "basic" Ex01.Route+     , FolderRoute "clock" Ex02.Route+     , FolderRoute "clockfast" Ex02.Route+     , FolderRoute "store" Ex03.Route+     ]++newtype TopRoute = TopRoute ()+  deriving newtype+    (Show, Eq, Ord, Generic, IsRoute)++instance EmaSite TopRoute where+  siteInput _ _ = pure $ pure ()+  siteOutput _enc _ _ =+    pure $ Ema.AssetGenerated Ema.Html renderIndex++main :: IO ()+main = do+  void $ Ema.runSite @R $ I () :* I () :* I () :* I Ex02.delayNormal :* I Ex02.delayFast :* I () :* Nil++renderIndex :: LByteString+renderIndex =+  tailwindLayout (H.title "Ex05_MultiRoute" >> H.base ! A.href "/") $+    H.div ! A.class_ "container mx-auto text-center mt-8 p-2" $ do+      H.p "You can compose Ema sites. Here are three sites composed to produce one, using Ema.Route.Lib.Multi:"+      H.ul ! A.class_ "flex flex-col justify-center .items-center mt-4 space-y-4" $ do+        -- NOTE: Since we don't have the MultiModel, we must hardcode the routes here.+        H.li $ routeElem "hello" "Ex00_Hello"+        H.li $ routeElem "basic" "Ex01_Basic"+        H.li $ routeElem "clock" "Ex02_Clock"+        H.li $ routeElem "clockfast" "Ex02_Clock (Fast)"+        H.li $ routeElem "store" "Ex03_Store"+  where+    routeElem r w = do+      H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! A.href r $ w

@@ -1,69 +1,111 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} -module Ema.Generate where+module Ema.Generate (+  generateSiteFromModel,+  generateSiteFromModel',+) where -import Control.Exception (throw)-import Control.Monad.Logger+import Control.Exception (throwIO)+import Control.Monad.Except (MonadError (throwError))+import Control.Monad.Logger (+  LogLevel (LevelError, LevelInfo),+  MonadLogger,+  MonadLoggerIO,+  logWithoutLoc,+ ) import Ema.Asset (Asset (..))-import Ema.Class (Ema (allRoutes, encodeRoute))+import Ema.CLI (crash)+import Ema.Route.Class (IsRoute (RouteModel, routePrism, routeUniverse))+import Ema.Route.Prism (+  checkRoutePrismGivenRoute,+  fromPrism_,+ )+import Ema.Site (EmaSite (siteOutput), EmaStaticSite)+import Optics.Core (review) import System.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, doesPathExist) import System.FilePath (takeDirectory, (</>)) import System.FilePattern.Directory (getDirectoryFiles)-import UnliftIO (MonadUnliftIO)  log :: MonadLogger m => LogLevel -> Text -> m ()-log = logWithoutLoc "Generate"+log = logWithoutLoc "ema.generate" -generate ::-  forall model route m.-  ( MonadIO m,-    MonadUnliftIO m,-    MonadLoggerIO m,-    Ema model route,-    HasCallStack-  ) =>+{- | Generate the static site at `dest`++  The *only* data we need is the `RouteModel`.+-}+generateSiteFromModel ::+  forall r m.+  (MonadIO m, MonadLoggerIO m, MonadFail m, Eq r, Show r, IsRoute r, EmaStaticSite r) =>+  -- | Target directory to write files to. Must exist.   FilePath ->-  model ->-  (model -> route -> Asset LByteString) ->+  -- | The model data used to generate assets.+  RouteModel r ->+  m [FilePath]+generateSiteFromModel dest model =+  withBlockBuffering $ do+    runExceptT (generateSiteFromModel' @r dest model) >>= \case+      Left err -> do+        crash "ema" err+      Right fs ->+        pure fs+  where+    -- Temporarily use block buffering before calling an IO action that is+    -- known ahead to log rapidly, so as to not hamper serial processing speed.+    withBlockBuffering f =+      hSetBuffering stdout (BlockBuffering Nothing)+        *> f+        <* (hSetBuffering stdout LineBuffering >> hFlush stdout)++-- | Like `generateSiteFromModel` but without buffering or error handling.+generateSiteFromModel' ::+  forall r m.+  (MonadIO m, MonadLoggerIO m, MonadError Text m, Eq r, Show r, EmaStaticSite r) =>+  FilePath ->+  RouteModel r ->   -- | List of generated files.   m [FilePath]-generate dest model render = do+generateSiteFromModel' dest model = do+  let enc = routePrism @r+      rp = fromPrism_ $ enc model+  -- Sanity checks   unlessM (liftIO $ doesDirectoryExist dest) $ do-    error $ "Destination does not exist: " <> toText dest-  let routes = allRoutes model-  log LevelInfo $ "Writing " <> show (length routes) <> " routes"-  let (staticPaths, generatedPaths) =-        lefts &&& rights $-          routes <&> \r ->-            case render model r of-              AssetStatic fp -> Left (r, fp)-              AssetGenerated _fmt s -> Right (encodeRoute model r, s)-  paths <- forM generatedPaths $ \(relPath, !s) -> do-    let fp = dest </> relPath-    log LevelInfo $ toText $ "W " <> fp-    liftIO $ do-      createDirectoryIfMissing True (takeDirectory fp)-      writeFileLBS fp s-      pure fp-  forM_ staticPaths $ \(r, staticPath) -> do-    liftIO (doesPathExist staticPath) >>= \case-      True ->-        -- TODO: In current branch, we don't expect this to be a directory.-        -- Although the user may pass it, but review before merge.-        copyDirRecursively (encodeRoute model r) staticPath dest-      False ->-        log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"+    throwError $ "Destination directory does not exist: " <> toText dest+  let routes = routeUniverse @r model+  when (null routes) $+    throwError "Your app's `routeUniverse` is empty; nothing to generate!"+  forM_ routes $ \route ->+    checkRoutePrismGivenRoute enc model route+      `whenLeft_` throwError+  -- For Github Pages   noBirdbrainedJekyll dest-  pure paths+  -- Enumerate and write all routes.+  log LevelInfo $ "Writing " <> show (length routes) <> " routes"+  fmap concat . forM routes $ \r -> do+    let fp = dest </> review rp r+    siteOutput rp model r >>= \case+      AssetStatic staticPath -> do+        liftIO (doesPathExist staticPath) >>= \case+          True ->+            -- NOTE: A static path can indeed be a directory. The user is not+            -- obliged to recursively list the files.+            copyRecursively staticPath fp+          False ->+            log LevelError $ toText $ "? " <> staticPath <> " (missing)"+        pure []+      AssetGenerated _fmt !s -> do+        writeFileGenerated fp s+        pure [fp] --- | Disable birdbrained hacks from GitHub to disable surprises like,--- https://github.com/jekyll/jekyll/issues/55+{- | Disable birdbrained hacks from GitHub to disable surprises like,+ https://github.com/jekyll/jekyll/issues/55+-} noBirdbrainedJekyll :: (MonadIO m, MonadLoggerIO m) => FilePath -> m () noBirdbrainedJekyll dest = do   let nojekyll = dest </> ".nojekyll"   liftIO (doesFileExist nojekyll) >>= \case-    True -> pure ()+    True -> pass     False -> do       log LevelInfo $ "Disabling Jekyll by writing " <> toText nojekyll       writeFileLBS nojekyll ""@@ -72,37 +114,46 @@   deriving stock (Show)   deriving anyclass (Exception) -copyDirRecursively ::-  ( MonadIO m,-    MonadUnliftIO m,-    MonadLoggerIO m,-    HasCallStack+writeFileGenerated :: (MonadLogger m, MonadIO m) => FilePath -> LByteString -> m ()+writeFileGenerated fp s = do+  log LevelInfo $ toText $ "W " <> fp+  liftIO $ do+    createDirectoryIfMissing True (takeDirectory fp)+    writeFileLBS fp s++{- | Copy a file or directory recursively to the target directory++  Like `cp -R src dest`.+-}+copyRecursively ::+  forall m.+  ( MonadIO m+  , MonadLoggerIO m   ) =>-  -- | Source file path relative to CWD-  FilePath ->-  -- | Absolute path to source file to copy.+  -- | Absolute path to source file or directory to copy.   FilePath ->-  -- | Directory *under* which the source file/dir will be copied+  -- | Target file or directory path.   FilePath ->   m ()-copyDirRecursively srcRel srcAbs destParent = do-  liftIO (doesFileExist srcAbs) >>= \case-    True -> do-      let b = destParent </> srcRel-      log LevelInfo $ toText $ "C " <> b-      copyFileCreatingParents srcAbs b-    False ->-      liftIO (doesDirectoryExist srcAbs) >>= \case-        False ->-          throw $ StaticAssetMissing srcAbs-        True -> do-          fs <- liftIO $ getDirectoryFiles srcAbs ["**"]-          forM_ fs $ \fp -> do-            let a = srcAbs </> fp-                b = destParent </> srcRel </> fp-            log LevelInfo $ toText $ "C " <> b-            copyFileCreatingParents a b+copyRecursively src dest = do+  fs <- enumerateFilesToCopy src dest+  forM_ fs $ \(a, b) -> do+    log LevelInfo $ toText $ "C " <> b+    copyFileCreatingParents a b   where+    enumerateFilesToCopy :: FilePath -> FilePath -> m [(FilePath, FilePath)]+    enumerateFilesToCopy a b = do+      liftIO (doesFileExist a) >>= \case+        True ->+          pure [(a, b)]+        False -> do+          liftIO (doesDirectoryExist a) >>= \case+            False ->+              liftIO $ throwIO $ StaticAssetMissing a+            True -> do+              fs <- liftIO $ getDirectoryFiles src ["**"]+              pure $ fs <&> \fp -> (a </> fp, b </> fp)+     copyFileCreatingParents a b =       liftIO $ do         createDirectoryIfMissing True (takeDirectory b)

@@ -1,62 +0,0 @@-module Ema.Route-  ( routeUrl,-    routeUrlWith,-    UrlStrategy (..),-  )-where--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 Network.URI.Slug qualified as Slug--data UrlStrategy-  = UrlPretty-  | UrlDirect-  deriving stock (Eq, Show, Ord)--instance FromJSON UrlStrategy where-  parseJSON val =-    f UrlPretty "pretty" val <|> f UrlDirect "direct" val-    where-      f :: UrlStrategy -> Text -> Value -> Parser UrlStrategy-      f c s v = do-        x <- parseJSON v-        guard $ x == s-        pure c---- | Return the relative URL of the given route------ 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 urlStrategy model =-  relUrlFromPath . encodeRoute model-  where-    relUrlFromPath :: FilePath -> Text-    relUrlFromPath fp =-      case T.stripSuffix (urlStrategySuffix urlStrategy) (toText fp) of-        Just htmlFp ->-          case nonEmpty (urlSlugFromText <$> T.splitOn "/" htmlFp) of-            Nothing ->-              ""-            Just (removeLastIf "index" -> partsSansIndex) ->-              T.intercalate "/" partsSansIndex-        Nothing ->-          T.intercalate "/" $ urlSlugFromText <$> T.splitOn "/" (toText fp)-      where-        urlSlugFromText = Slug.encodeSlug . fromString @Slug.Slug . toString-        removeLastIf :: Eq a => a -> NonEmpty a -> [a]-        removeLastIf x xs =-          if NE.last xs == x-            then NE.init xs-            else toList xs-        urlStrategySuffix = \case-          UrlPretty -> ".html"-          UrlDirect -> ""--routeUrl :: forall r model. Ema model r => model -> r -> Text-routeUrl =-  routeUrlWith UrlPretty

@@ -0,0 +1,32 @@+module Ema.Route.Class (+  IsRoute (RouteModel, routePrism, routeUniverse),+) where++import Ema.Route.Prism (Prism_, toPrism_)+import Optics.Core (only)+import Prelude hiding (All, Generic)++{- | Class of Ema routes++  An Ema route has a @Prism'@ `routePrism`, that knows how to convert it to/from+  filepaths.  As well as an universe function, `routeUniverse`, that gives all+  possible route values in a static site.++  Both functions take the associated model, `RouteModel r`, as an argument.+-}+class IsRoute r where+  type RouteModel r :: Type++  -- | An optics `Prism'` that denotes how to encode and decode a route.+  routePrism :: RouteModel r -> Prism_ FilePath r++  -- | All possible route values for the given `RouteModel`.+  --+  -- This is used in determining the pages to statically generate.+  routeUniverse :: RouteModel r -> [r]++-- Single element routes are represented by `()`+instance IsRoute () where+  type RouteModel () = ()+  routePrism () = toPrism_ $ only "index.html"+  routeUniverse () = one ()

@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Ema.Route.Generic (+  -- * Generic deriving types+  GenericRoute (GenericRoute),+  HasSubRoutes,+  HasSubModels,+  WithModel,+  WithSubRoutes,+  WithSubModels,++  -- * Customizing generic deriving+  GenericRouteOpt (..),++  -- * Handy functions+  subModels,++  -- * Export these for DerivingVia coercion representations+  FileRoute (FileRoute),+  FolderRoute (FolderRoute),+) where++import Ema.Route.Class (IsRoute (..))+import Ema.Route.Generic.RGeneric+import Ema.Route.Generic.SubModel as X+import Ema.Route.Generic.SubRoute as X+import Ema.Route.Generic.Verification+import Ema.Route.Lib.File (FileRoute (FileRoute))+import Ema.Route.Lib.Folder (FolderRoute (FolderRoute))+import Ema.Route.Lib.Multi (MultiModel, MultiRoute)+import Ema.Route.Prism.Type (mapRoutePrism)+import GHC.Generics qualified as GHC+import Generics.SOP (All, I (..), NP)+import Optics.Core (ReversibleOptic (re), coercedTo, equality, review, (%))+import Prelude hiding (All, Generic)++-- | DerivingVia type to generically derive `IsRoute`+newtype GenericRoute r (opts :: [Type]) = GenericRoute r+  deriving stock (GHC.Generic)++{- | Associate the route with the given model type.++ Default: `()`+-}+data WithModel (r :: Type)++{- | Specify isomorphic types to delegate sub-route behaviour. Usually this is identical to the route product type.++    The isomorphism is specified by @Coercible@.++    The default implementation uses @FileRoute@ for terminal routes, and+    @FolderRoute@ (with constructor prefix stripped) for wrapping sub-routes types.+-}+data WithSubRoutes (subRoutes :: [Type])++{- | Specify the @Data.Generics.Product.Any.HasAny@ selector type for sub models++  Note: if the selector is a @Symbol@ you must wrap it in a @Proxy@.+-}+data WithSubModels (subModels :: [Type])++{- | Typeclass to control `GenericRoute` behaviour.++  The `FooM` type enables users to define their type optionally, whose default+  is specified in the `Foo` type family (further below).++  You can define your own options, for example:++  @+    data MySubRoutes+    instance GenericRouteOpt r MySubRoutes where+      type+        OptSubRoutesM r MySubRoutes =+          'Just (GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r))+  @++  And use it as:++  > deriving via (GenericRoute MyRoute '[MySubRoutes])+-}+class GenericRouteOpt (r :: Type) (opt :: Type) where+  type OptModelM r opt :: Maybe Type+  type OptModelM r opt = 'Nothing+  type OptSubRoutesM r opt :: Maybe [Type]+  type OptSubRoutesM r opt = 'Nothing+  type OptSubModelsM r opt :: Maybe [Type]+  type OptSubModelsM r opt = 'Nothing++instance GenericRouteOpt r (WithModel t) where+  type OptModelM r (WithModel t) = 'Just t+instance GenericRouteOpt r (WithSubRoutes t) where+  type OptSubRoutesM r (WithSubRoutes t) = 'Just t+instance GenericRouteOpt r (WithSubModels t) where+  type OptSubModelsM r (WithSubModels t) = 'Just t++type family OptModel r (opts :: [Type]) :: Type where+  OptModel r '[] = ()+  OptModel r (opt ': opts) = FromMaybe (OptModel r opts) (OptModelM r opt)++type family OptSubRoutes r (opts :: [Type]) :: [Type] where+  OptSubRoutes r '[] = GSubRoutes (RDatatypeName r) (RConstructorNames r) (RCode r)+  OptSubRoutes r (opt ': opts) = FromMaybe (OptSubRoutes r opts) (OptSubRoutesM r opt)++type family OptSubModels r (opts :: [Type]) :: [Type] where+  OptSubModels r '[] = MultiModel (SubRoutes r)+  OptSubModels r (opt ': opts) = FromMaybe (OptSubModels r opts) (OptSubModelsM r opt)++type family FromMaybe (def :: a) (maybe :: Maybe a) :: a where+  FromMaybe def 'Nothing = def+  FromMaybe def ( 'Just a) = a++type GenericRouteOpts r opts = All (GenericRouteOpt r) opts++instance+  ( GenericRouteOpts r opts+  , RGeneric r+  , ValidSubRoutes r (OptSubRoutes r opts)+  ) =>+  HasSubRoutes (GenericRoute r opts)+  where+  type SubRoutes (GenericRoute r opts) = OptSubRoutes r opts++instance+  ( VerifyModels+      (RouteModel (GenericRoute r opts))+      (MultiModel (SubRoutes (GenericRoute r opts)))+      (OptSubModels r opts)+  , VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))+  , GSubModels (RouteModel (GenericRoute r opts)) (MultiModel (OptSubRoutes r opts)) (OptSubModels r opts)+  , HasSubRoutes (GenericRoute r opts)+  , GenericRouteOpts r opts+  ) =>+  HasSubModels (GenericRoute r opts)+  where+  subModels m =+    gsubModels @_ @(RouteModel (GenericRoute r opts))+      @(MultiModel (SubRoutes (GenericRoute r opts)))+      @(OptSubModels r opts)+      m++instance+  ( VerifyRoutes (RCode r) (SubRoutes (GenericRoute r opts))+  , HasSubRoutes r+  , HasSubModels r+  , ValidSubRoutes r (SubRoutes r)+  , RGeneric r+  , mr ~ MultiRoute (SubRoutes r)+  , mm ~ MultiModel (SubRoutes r)+  , RouteModel r ~ OptModel r opts+  , RouteModel mr ~ NP I mm+  , IsRoute mr+  , GenericRouteOpts r opts+  ) =>+  IsRoute (GenericRoute r opts)+  where+  type RouteModel (GenericRoute r opts) = OptModel r opts+  routePrism =+    routePrism @mr+      & mapRoutePrism equality (re (subRoutesIso @r) % coercedTo) (subModels @r)+  routeUniverse m =+    GenericRoute . review subRoutesIso+      <$> routeUniverse (subModels @r m)

@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Ema.Route.Generic.Example where++import Data.Generics.Sum.Any (AsAny (_As))+import Data.SOP (I (..), NP (..))+import Ema+import Ema.Asset qualified as Asset+import Ema.Route.Generic+import Ema.Route.Generic.TH+import Generics.SOP qualified as SOP+import Generics.SOP.TH qualified as SOP+import Optics.Core ((%))+import Optics.Prism (prism')++-- ----------+-- Examples+-- ----------++type M = (Int, Int, String)++data R = R_Index | R_Foo | R_Bar NumRoute | R_Bar2 NumRoute+  deriving stock (Show, Eq, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving (HasSubRoutes, IsRoute) via (GenericRoute R '[WithModel M])++-- We must derive this manually due to ambiguity in field types (Int)+instance HasSubModels R where+  subModels (a, b, _) =+    I () :* I () :* I a :* I b :* Nil++data NumRoute = NumRoute+  deriving stock (Show, Eq, Generic)++instance IsRoute NumRoute where+  type RouteModel NumRoute = Int+  routePrism n =+    let fp = show n <> ".html"+     in toPrism_ $+          prism' (const fp) $ \s -> do+            guard $ s == fp+            pure NumRoute+  routeUniverse _ = [NumRoute]++instance EmaSite R where+  siteInput _ () = pure $ pure (42, 21, "inner")+  siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m++-- --warnings -c "cabal repl ema -f with-examples" -T Ema.Route.Generic.main  --setup ":set args gen /tmp"+main :: IO ()+main = Ema.runSite_ @R ()++-- ---+-- Let's try defining a top-level route using `R` to see how EmaSite instances compose.+-- --++type TM = (M, String)++data TR = TR_Index | TR_Inner R+  deriving stock (Show, Eq, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute TR '[WithModel TM])++instance EmaSite TR where+  siteInput x () = do+    m1 <- siteInput @R x ()+    pure $ fmap (,"TOP") m1+  siteOutput rp m = \case+    r@TR_Index ->+      pure $ Asset.AssetGenerated Asset.Html $ show r <> show m+    TR_Inner r ->+      -- Might as well provide a `innerSiteOutput (_As @TR_Inner)`?+      siteOutput @R (rp % _As @"TR_Inner") (trInnerModel m) r+    where+      trInnerModel model =+        let I () :* I m' :* Nil = subModels @TR model+         in m'++mainTop :: IO ()+mainTop = Ema.runSite_ @TR ()++-- ---+-- Ensure that the constant model case (simple one) still works+-- --++type M2 = (Int, String)++data R2 = R2_Index | R2_Foo | R2_Bar BarRoute | R2_Bar2 BarRoute+  deriving stock (Show, Eq, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute R2 '[WithModel M2])++data BarRoute = BarRoute+  deriving stock (Show, Eq, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving (HasSubRoutes, HasSubModels, IsRoute) via (GenericRoute BarRoute '[WithModel M2])++instance EmaSite R2 where+  siteInput _ () = pure $ pure (21, "inner")+  siteOutput _ m r = pure $ Asset.AssetGenerated Asset.Html $ show r <> show m++mainConst :: IO ()+mainConst = Ema.runSite_ @R2 ()++-- ---+-- Ensure deriveIsRoute works with (partial) subroutes+-- --++data M3+  = M3+  deriving stock (Eq, Show, Generic)++data R3+  = R3_Sub R3_SubR+  | R3_Index++data R3_SubR+  = R3_SubR+  deriving stock (Show, Eq, Ord, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving+    (HasSubRoutes, HasSubModels, IsRoute)+    via ( GenericRoute+            R3_SubR+            '[ WithSubRoutes+                '[ FileRoute "example.html"+                 ]+             ]+        )++SOP.deriveGeneric ''R3+deriveIsRoute+  ''R3+  [t|+    [ WithModel M3+    , WithSubRoutes+        [ R3_SubR+        , ()+        ]+    ]+    |]++-- ---+-- Ensure deriveIsRoute works in a no-subroute case+-- --++data M4+  = M4+  deriving stock (Eq, Show, Generic)++data R4+  = R4_Index+  | R3_About++SOP.deriveGeneric ''R4+deriveIsRoute ''R4 [t|'[WithModel M4]|]

@@ -0,0 +1,99 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}++module Ema.Route.Generic.RGeneric (+  RGeneric (RCode, rfrom, rto),+  RHasDatatypeInfo (RDatatypeName, RConstructorNames),+) where++import GHC.TypeLits (ErrorMessage (Text), TypeError)+import GHC.TypeLits.Extra (Impossible (impossible), TypeErr)+import Generics.SOP+import Generics.SOP.Type.Metadata qualified as SOPM+import Prelude hiding (All, Generic)++-- | Like `Generic` but for Route types only.+class (Generic r, HasDatatypeInfo r) => RGeneric r where+  type RCode r :: [Type]+  rfrom :: r -> NS I (RCode r)+  rto :: NS I (RCode r) -> r++class (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where+  type RDatatypeName r :: SOPM.DatatypeName+  type RConstructorNames r :: [SOPM.ConstructorName]++instance (Generic r, HasDatatypeInfo r, RGeneric' (Code r), All RouteNP (Code r)) => RGeneric r where+  type RCode r = RCode' (Code r)+  rfrom = rfrom' @(Code r) . unSOP . from+  rto = to . SOP . rto' @(Code r)++instance (RGeneric r, HasDatatypeInfo r) => RHasDatatypeInfo r where+  type RDatatypeName r = RDatatypeName' (DatatypeInfoOf r)+  type RConstructorNames r = RConstructorNames' (DatatypeInfoOf r)++class RGeneric' (xss :: [[Type]]) where+  type RCode' xss :: [Type]+  rfrom' :: NS (NP I) xss -> NS I (RCode' xss)+  rto' :: NS I (RCode' xss) -> NS (NP I) xss++instance RGeneric' '[] where+  type RCode' '[] = '[]+  rfrom' = \case {}+  rto' = \case {}++instance (RGeneric' xss, RouteNP xs) => RGeneric' (xs ': xss) where+  type RCode' (xs ': xss) = RouteNPType xs ': RCode' xss+  rfrom' = \case+    Z routeNP -> Z $ I $ fromRouteNP routeNP+    S rest -> S $ rfrom' @xss rest+  rto' = \case+    Z (I t) -> Z $ toRouteNP t+    S rest -> S $ rto' @xss rest++type family RDatatypeName' (info :: SOPM.DatatypeInfo) :: SOPM.DatatypeName where+  RDatatypeName' ( 'SOPM.ADT _ name _ _) =+    name+  RDatatypeName' ( 'SOPM.Newtype _ name _) =+    name++type family RConstructorNames' (info :: SOPM.DatatypeInfo) :: [SOPM.ConstructorName] where+  RConstructorNames' ( 'SOPM.ADT _ _ constrs _) =+    GetConstructorNames constrs+  RConstructorNames' ( 'SOPM.Newtype _ _ constr) =+    '[GetConstructorName constr]++type family GetConstructorName (info :: SOPM.ConstructorInfo) :: SOPM.ConstructorName where+  GetConstructorName ( 'SOPM.Constructor name) =+    name+  GetConstructorName ( 'SOPM.Infix name _ _) =+    name+  GetConstructorName ( 'SOPM.Record name _) =+    name++type family GetConstructorNames (infos :: [SOPM.ConstructorInfo]) :: [SOPM.ConstructorName] where+  GetConstructorNames '[] = '[]+  GetConstructorNames (x ': xs) = GetConstructorName x ': GetConstructorNames xs++{- | Class of `NP` that can be used in a route tyupe.++    Ensures that the constructor can have 0 or 1 products only.+-}+class RouteNP (xs :: [Type]) where+  type RouteNPType xs :: Type+  fromRouteNP :: NP I xs -> RouteNPType xs+  toRouteNP :: RouteNPType xs -> NP I xs++instance RouteNP '[] where+  type RouteNPType '[] = ()+  fromRouteNP Nil = ()+  toRouteNP () = Nil++instance RouteNP (x ': '[]) where+  type RouteNPType (x ': '[]) = x+  fromRouteNP (I x :* Nil) = x+  toRouteNP x = I x :* Nil++instance (TypeErr ( 'Text "MultiRoute: too many arguments")) => RouteNP (x ': x' ': xs) where+  type RouteNPType (x ': x' ': xs) = TypeError ( 'Text "MultiRoute: too many arguments")+  fromRouteNP _ = impossible+  toRouteNP _ = impossible

@@ -0,0 +1,42 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Ema.Route.Generic.SubModel (+  HasSubModels (subModels),+  -- DerivingVia types+  GSubModels (..),+) where++import Data.Generics.Product (HasAny (the))+import Ema.Route.Class (IsRoute (RouteModel))+import Ema.Route.Generic.SubRoute (HasSubRoutes (SubRoutes))+import Ema.Route.Lib.Multi (MultiModel)+import Generics.SOP (I (..), NP (Nil, (:*)))+import Optics.Core (united, view)+import Prelude hiding (All)++class HasSubRoutes r => HasSubModels r where+  -- | Break the model into a list of sub-models used correspondingly by the sub-routes.+  subModels :: RouteModel r -> NP I (MultiModel (SubRoutes r))++class GSubModels m (ms :: [Type]) (lookups :: [k]) where+  gsubModels :: m -> NP I ms++instance GSubModels m '[] '[] where+  gsubModels _ = Nil++instance+  {-# OVERLAPPING #-}+  (HasAny s m m t t, GSubModels m ms ss) =>+  GSubModels m (t ': ms) (s ': ss)+  where+  gsubModels m = I (view (the @s @m @_ @t @_) m) :* gsubModels @_ @m @ms @ss m++-- Useful instances to support varied types in `WithSubModels` list.++instance {-# OVERLAPPING #-} HasAny () s s () () where+  the = united++instance HasAny sel s t a b => HasAny (Proxy sel) s t a b where+  the = the @sel

@@ -0,0 +1,113 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}++module Ema.Route.Generic.SubRoute (+  HasSubRoutes (SubRoutes),+  subRoutesIso,+  -- DerivingVia types+  GSubRoutes,+  gtoSubRoutes,+  gfromSubRoutes,+  ValidSubRoutes,+) where++import Data.SOP.Constraint (AllZipF)+import Data.SOP.NS (trans_NS)+import Ema.Route.Generic.RGeneric (RGeneric (..))+import Ema.Route.Lib.Multi (MultiRoute)+import GHC.TypeLits (AppendSymbol, Symbol)+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+import GHC.TypeLits.Extra.Symbol (StripPrefix, ToLower)+import Ema.Route.Lib.File (FileRoute)+import Ema.Route.Lib.Folder (FolderRoute)+#else +import GHC.TypeLits+#endif+import Generics.SOP (All, I (..), NS, SameShapeAs, Top, unI)+import Generics.SOP.Type.Metadata qualified as SOPM+import Optics.Core (Iso', iso)+import Prelude hiding (All)++{- | HasSubRoutes is a class of routes with an underlying MultiRoute (and MultiModel) representation.++ The idea is that by deriving HasSubRoutes (and HasSubModels), we get IsRoute for free (based on MultiRoute).++ TODO: Rename this class, or change the API.+-}+class HasSubRoutes r where+  -- | The sub-routes in the `r` (for each constructor).+  type SubRoutes r :: [Type]++subRoutesIso ::+  forall r.+  ( RGeneric r+  , HasSubRoutes r+  , ValidSubRoutes r (SubRoutes r)+  ) =>+  Iso' r (MultiRoute (SubRoutes r))+subRoutesIso =+  iso (gtoSubRoutes @r . rfrom) (rto . gfromSubRoutes @r)++gtoSubRoutes ::+  forall r subRoutes.+  ( RGeneric r+  , ValidSubRoutes r subRoutes+  ) =>+  NS I (RCode r) ->+  MultiRoute subRoutes+gtoSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI)++gfromSubRoutes ::+  forall r subRoutes.+  ( RGeneric r+  , ValidSubRoutes r subRoutes+  ) =>+  MultiRoute subRoutes ->+  NS I (RCode r)+gfromSubRoutes = trans_NS (Proxy @Coercible) (I . coerce . unI)++-- | @subRoutes@ are valid sub-routes of @r@+type ValidSubRoutes r subRoutes =+  ( SameShapeAs (RCode r) subRoutes+  , SameShapeAs subRoutes (RCode r)+  , All Top (RCode r)+  , All Top subRoutes+  , AllZipF Coercible (RCode r) subRoutes+  , AllZipF Coercible subRoutes (RCode r)+  )++#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)+type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where+  GSubRoutes _ _ '[] = '[]+  GSubRoutes name (c ': cs) (() ': xs) =+    -- TODO: The .html suffix part should be overridable.+    FileRoute (Constructor2RoutePath name c ".html")+      ': GSubRoutes name cs xs+  GSubRoutes name (c ': cs) (x ': xs) =+    FolderRoute (Constructor2RoutePath name c "") x+      ': GSubRoutes name cs xs++type family+  Constructor2RoutePath+    (name :: SOPM.DatatypeName)+    (constr :: SOPM.ConstructorName)+    (suffix :: Symbol) ::+    Symbol+  where+  Constructor2RoutePath name constr suffix =+    AppendSymbol+      ( -- Instead of ToLower we want Camel2Kebab here, ideally.+        -- So that `Foo_BarQux` encodes to bar-qux instead of barqux.+        ToLower+          ( StripPrefix+              (AppendSymbol name "_")+              constr+          )+      )+      suffix+#else +type family GSubRoutes (name :: SOPM.DatatypeName) (constrs :: [SOPM.ConstructorName]) (xs :: [Type]) :: [Type] where+  GSubRoutes _ _ _ = TypeError ('Text "GHC 9.2 is required for anyclass deriving of HasSubRoutes")+#endif

@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}++module Ema.Route.Generic.TH (+  -- * Main TH+  deriveIsRoute,++  -- * Convenient re-exports+  deriveGeneric,+  module X,+) where++import Ema.Route.Class (IsRoute)+import Ema.Route.Generic as X+import Generics.SOP.TH (deriveGeneric)+import Language.Haskell.TH++{- | @deriveIsRoute route model subroutes@ derives 'HasSubRoutes', 'HasSubModels', and 'IsRoute' for the given @route@.++Subroutes are optionally supplied, but if they are then the length of the list must be the same as the number of+constructors in @route@.++TODO: Add TypeErrors to catch mismatched 'WithSubRoutes' list shapes at the generic deriving level?+-}+deriveIsRoute :: Name -> TypeQ -> Q [Dec]+deriveIsRoute route opts = do+  opts' <- opts+  let instances =+        [ ''HasSubRoutes+        , ''HasSubModels+        , ''IsRoute+        ]+  pure $+    flip fmap instances $ \i ->+      StandaloneDerivD+        ( Just+            ( ViaStrategy+                ( ConT ''GenericRoute+                    `AppT` (ConT route)+                    `AppT` opts'+                )+            )+        )+        []+        (ConT i `AppT` ConT route)

@@ -0,0 +1,57 @@+{-# LANGUAGE UndecidableInstances #-}++module Ema.Route.Generic.Verification (+  type VerifyModels,+  type VerifyRoutes,+) where++import Data.Generics.Product.Any (HasAny)+import GHC.TypeLits++{- | @VerifyModels model routeModels lookups@ verifies the given @model@ to ensure that there+exists a valid @HasSubModels@ instance for the given combination of (model, routeModels, lookups).+-}+type family VerifyModels model (subModels :: [Type]) (lookups :: [Type]) :: Constraint where+  VerifyModels m '[] '[] = ()+  VerifyModels m '[] t =+    TypeError+      ( 'Text "'WithSubModels' has extra unnecessary types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType t)+  VerifyModels m f '[] =+    TypeError+      ( 'Text "'WithSubModels' is missing submodel types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType f)+  VerifyModels model (model ': fs) (model ': ss) =+    -- This checks the simple case that (the model ~ the submodel),+    -- because it doesn't necessarily have to have a generic instance in this case.+    -- After that, we can /assume/ the model has a generic instance to allow us to inspect its+    -- structure statically to verify that the correct submodel exists.+    VerifyModels model fs ss+  VerifyModels model (subModel ': subModels) (sel ': sels) =+    ( HasAny sel model model subModel subModel+    , VerifyModels model subModels sels+    )++{- | @VerifyRoutes route rep subroutes@ verifies the given @route@ to ensure that there+exists a valid @HasSubRoutes@ instance for @route@ given its @rep@ and the @subroutes@ it is generic-deriving from.++Invariant: code ~ Code route+-}+type family VerifyRoutes (rcode :: [Type]) (subRoutes :: [Type]) :: Constraint where+  VerifyRoutes '[] '[] = ()+-- Inconsistent lengths+  VerifyRoutes '[] t =+    TypeError+      ( 'Text "'WithSubRoutes' has extra unnecessary types: " ':$$: 'Text "" ':$$: 'Text "\t" ':<>: 'ShowType t)+  VerifyRoutes t '[] =+    TypeError+      ( 'Text "'WithSubRoutes' is missing subroutes for:"+          ':$$: 'Text ""+          ':$$: ( 'Text "\t" ':<>: 'ShowType t)+      )+-- Subroute rep is unit (REVIEW: this case not strictly necessary anymore; should it be removed?)+  VerifyRoutes (() ': rs) (() : rs') = VerifyRoutes rs rs'+  VerifyRoutes (r' ': rs) (() : rs') =+    TypeError+      ( 'Text "A 'WithSubRoutes' entry is '()' instead of the expected: "+          ':$$: 'ShowType r'+      )+  VerifyRoutes (r1 ': rs) (r2 ': rs') = (Coercible r1 r2, VerifyRoutes rs rs')

@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}++module Ema.Route.Lib.Extra.PandocRoute (+  -- * Route+  PandocRoute (..),+  mkPandocRoute,++  -- * Model and Arg+  Model (..),+  Arg (..),++  -- * Looking up Pandoc values in model+  lookupPandocRoute,++  -- * Rendering+  PandocHtml (..),+  PandocError (..),+) where++import Control.Exception (throw, throwIO)+import Control.Monad.Logger (+  MonadLogger,+  MonadLoggerIO,+  logInfoNS,+ )+import Data.Default (Default (..))+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.SOP (I (I), NP (..))+import Data.Set qualified as Set+import Ema+import Ema.CLI qualified+import Ema.Route.Generic.TH+import Ema.Route.Lib.Extra.SlugRoute+import Generics.SOP qualified as SOP+import System.FilePath ((</>))+import System.UnionMount qualified as UnionMount+import Text.Pandoc (Pandoc, ReaderOptions, runIO)+import Text.Pandoc qualified as Pandoc+import Text.Pandoc.Sources (ToSources)+import UnliftIO (MonadUnliftIO)++-- | Represents the relative path to a file that pandoc can parse.+newtype PandocRoute = PandocRoute {unPandocRoute :: SlugRoute Pandoc}+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)+  deriving+    (HasSubRoutes, IsRoute)+    via ( GenericRoute+            PandocRoute+            '[ WithModel Model+             , WithSubRoutes+                '[ SlugRoute Pandoc+                 ]+             ]+        )++instance HasSubModels PandocRoute where+  subModels m = I (Map.mapKeys unPandocRoute $ modelPandocs m) :* Nil++instance IsString PandocRoute where+  fromString fp = maybe (error $ "Bad path: " <> toText fp) snd $ mkPandocRoute fp++mkPandocRoute :: FilePath -> Maybe (String, PandocRoute)+mkPandocRoute fp = do+  (ext, r) <- mkSlugRoute fp+  pure (ext, PandocRoute r)++data Model = Model+  { modelArg :: Arg+  , modelPandocs :: Map PandocRoute Pandoc+  }+  deriving stock (Generic)++lookupPandocRoute :: Model -> PandocRoute -> Maybe (Pandoc, Pandoc -> PandocHtml)+lookupPandocRoute model r = do+  pandoc <- Map.lookup r $ modelPandocs model+  let render = PandocHtml . renderHtml (argWriterOpts $ modelArg model)+  pure (pandoc, render)+  where+    renderHtml :: HasCallStack => Pandoc.WriterOptions -> Pandoc -> Text+    renderHtml writerSettings pandoc =+      either (throw . PandocError_RenderError . show) id $+        Pandoc.runPure $ Pandoc.writeHtml5String writerSettings pandoc++data Arg = Arg+  { -- Base directory+    argBaseDir :: FilePath+  , -- Pandoc reader formats supported, as file extension; eg: '.md'+    argFormats :: Set String+  , argReaderOpts :: Pandoc.ReaderOptions+  , argWriterOpts :: Pandoc.WriterOptions+  }+  deriving stock (Generic)++instance Default Arg where+  def = Arg "." formats defaultReaderOpts defaultWriterOpts+    where+      formats = Set.fromList knownPandocFormats+      defaultReaderOpts = def {Pandoc.readerExtensions = exts}+      defaultWriterOpts = def {Pandoc.writerExtensions = exts}+      exts :: Pandoc.Extensions+      exts =+        -- Sensible defaults for Markdown and others+        Pandoc.pandocExtensions <> Pandoc.extensionsFromList [Pandoc.Ext_attributes]++instance EmaSite PandocRoute where+  type SiteArg PandocRoute = Arg++  -- Returns the `Pandoc` AST along with the function that renders it to HTML.+  type SiteOutput PandocRoute = (Pandoc, Pandoc -> PandocHtml)++  siteInput _ arg = do+    fmap (Model arg) <$> pandocFilesDyn (argBaseDir arg) (argFormats arg) (argReaderOpts arg)+  siteOutput _rp model r = do+    maybe (liftIO $ throwIO $ PandocError_Missing $ show r) pure $ lookupPandocRoute model r++pandocFilesDyn ::+  forall m.+  (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>+  FilePath ->+  Set String ->+  ReaderOptions ->+  m (Dynamic m (Map PandocRoute Pandoc))+pandocFilesDyn baseDir formats readerOpts = do+  let pats =+        toList formats <&> \ext ->+          ((), "**/*" <> ext)+      ignorePats = [".*"]+      model0 = mempty+  Dynamic <$> UnionMount.mount baseDir pats ignorePats model0 (const handleUpdate)+  where+    -- Take the file that got changed and update our in-memory `Model` accordingly.+    handleUpdate ::+      (MonadIO m, MonadLogger m, MonadLoggerIO m) =>+      FilePath ->+      UnionMount.FileAction () ->+      m (Map PandocRoute Pandoc -> Map PandocRoute Pandoc)+    handleUpdate fp = \case+      UnionMount.Refresh _ _ -> do+        mData <- readSource fp+        pure $ maybe id (uncurry Map.insert) mData+      UnionMount.Delete ->+        pure $ maybe id (Map.delete . snd) $ mkPandocRoute fp+    readSource :: (MonadIO m, MonadLogger m, MonadLoggerIO m) => FilePath -> m (Maybe (PandocRoute, Pandoc))+    readSource fp = runMaybeT $ do+      (ext, r :: PandocRoute) <- hoistMaybe (mkPandocRoute fp)+      guard $ ext `Set.member` formats+      log $ "Reading " <> toText fp+      s :: Text <- fmap decodeUtf8 $ readFileBS $ baseDir </> fp+      liftIO (runIO $ readPandocSource readerOpts ext s) >>= \case+        Left err -> Ema.CLI.crash "PandocRoute" $ show err+        Right doc -> do+          pure (r, doc)++log :: MonadLogger m => Text -> m ()+log = logInfoNS "PandocRoute"++data PandocError+  = PandocError_Missing Text+  | PandocError_RenderError Text+  deriving stock (Eq, Show)+  deriving anyclass (Exception)++newtype PandocHtml = PandocHtml {unPandocHtml :: Text}+  deriving stock (Eq, Generic)++-- Pandoc reader abstraction+--+-- TODO: Can we refactor this using,+-- https://github.com/jgm/pandoc/blob/16f0316fbaa4d667ba40772969ab8e28fea6a493/src/Text/Pandoc/App/FormatHeuristics.hs#L36++knownPandocFormats :: [String]+knownPandocFormats = [".md", ".org"]++formatFromExt :: String -> Text+formatFromExt = \case+  ".md" -> "markdown"+  ".org" -> "org"+  ext -> throw $ UnsupportedPandocFormat ext++readPandocSource ::+  forall m a.+  (Pandoc.PandocMonad m, ToSources a) =>+  ReaderOptions ->+  [Char] ->+  a ->+  m Pandoc+readPandocSource readerOpts ext s =+  case List.lookup (formatFromExt ext) Pandoc.readers of+    Just (Pandoc.TextReader f) -> f readerOpts s+    _ -> throw $ UnsupportedPandocFormat ext++data UnsupportedPandocFormat = UnsupportedPandocFormat String+  deriving stock (Eq, Show)+  deriving anyclass (Exception)

@@ -0,0 +1,40 @@+module Ema.Route.Lib.Extra.SlugRoute (+  SlugRoute,+  mkSlugRoute,+) where++import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Ema.Route.Class (IsRoute (..))+import Ema.Route.Prism (htmlSuffixPrism, toPrism_)+import Network.URI.Slug (Slug)+import Network.URI.Slug qualified as Slug+import Optics.Core (prism', (%))+import System.FilePath (splitExtension, splitPath)++{- | Route to a file that is associated with a value of type `a`.++ A route to foo/bar/qux.md, for instance, is encoded as /foo/bar/qux. ie., the+ extension is dropped.+-}+newtype SlugRoute (a :: Type) = SlugRoute {unSlugRoute :: NonEmpty Slug}+  deriving stock (Eq, Ord, Show, Generic)++instance IsRoute (SlugRoute a) where+  type RouteModel (SlugRoute a) = Map (SlugRoute a) a+  routePrism m =+    let encode (SlugRoute slugs) =+          toString $ T.intercalate "/" $ Slug.unSlug <$> toList slugs+        decode fp = do+          guard $ not $ null fp+          slugs <- nonEmpty $ fromString . toString <$> T.splitOn "/" (toText fp)+          let r = SlugRoute slugs+          guard $ Map.member r m+          pure r+     in toPrism_ $ htmlSuffixPrism % prism' encode decode+  routeUniverse = Map.keys++mkSlugRoute :: forall a. FilePath -> Maybe (String, SlugRoute a)+mkSlugRoute (splitExtension -> (relFp, ext')) = do+  let slugs = fromString . toString . T.dropWhileEnd (== '/') . toText <$> splitPath relFp+  (ext',) <$> viaNonEmpty SlugRoute slugs

@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use impureThrow" #-}++module Ema.Route.Lib.Extra.StaticRoute (+  StaticRoute,+  Model (..),++  -- * Helpers+  staticRouteUrl,+) where++import Control.Exception (throw)+import Control.Monad.Logger (MonadLogger, MonadLoggerIO)+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Some (Some)+import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)+import Ema+import Ema.CLI qualified+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Optics.Core (Prism', prism')+import System.FilePath (takeExtension, (</>))+import System.UnionMount qualified as UnionMount+import UnliftIO (MonadUnliftIO)++-- | Route to a static file under @baseDir@.+newtype StaticRoute (baseDir :: Symbol) = StaticRoute {unStaticRoute :: FilePath}+  deriving newtype (Eq, Ord, Show)+  deriving stock (Generic)++data Model = Model+  { modelCliAction :: Some Ema.CLI.Action+  , modelFiles :: Map FilePath UTCTime+  }+  deriving stock (Eq, Show, Generic)++instance IsRoute (StaticRoute baseDir) where+  type RouteModel (StaticRoute baseDir) = Model+  routePrism (modelFiles -> files) =+    let enc =+          unStaticRoute+        dec fp =+          StaticRoute fp <$ guard (Map.member fp files)+     in toPrism_ $ prism' enc dec+  routeUniverse (modelFiles -> files) =+    StaticRoute <$> Map.keys files++instance KnownSymbol baseDir => EmaSite (StaticRoute baseDir) where+  siteInput cliAct _ = do+    files <- staticFilesDynamic $ symbolVal (Proxy @baseDir)+    pure $ Model cliAct <$> files+  siteOutput _ _ (StaticRoute path) =+    pure $ Ema.AssetStatic $ symbolVal (Proxy @baseDir) </> path++staticFilesDynamic ::+  forall m.+  (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>+  FilePath ->+  m (Dynamic m (Map FilePath UTCTime))+staticFilesDynamic baseDir = do+  let pats = [((), "**")]+      ignorePats = [".*"]+      model0 = mempty+  Dynamic <$> UnionMount.mount baseDir pats ignorePats model0 (const handleUpdate)+  where+    handleUpdate ::+      FilePath ->+      UnionMount.FileAction () ->+      m (Map FilePath UTCTime -> Map FilePath UTCTime)+    handleUpdate fp = \case+      UnionMount.Refresh _ _ -> do+        lastAccessed <- liftIO getCurrentTime+        pure $ Map.insert fp lastAccessed+      UnionMount.Delete -> do+        pure $ Map.delete fp++-- | Like `Ema.routeUrl`, but looks up the value and appends it to URL in live-server (for force-reload in browser)+staticRouteUrl ::+  forall s baseDir.+  (IsString s, HasCallStack) =>+  Prism' FilePath (StaticRoute baseDir) ->+  RouteModel (StaticRoute baseDir) ->+  FilePath ->+  s+staticRouteUrl rp model fp =+  let lastAccessed = lookupMust fp model+      tag = toText $ formatTime defaultTimeLocale "%s" lastAccessed+      url = Ema.routeUrl rp $ StaticRoute fp+   in fromString . toString $ url <> refreshAddendum tag+  where+    -- Force the browser to reload the static file referenced+    refreshAddendum tag =+      fromMaybe "" $ do+        -- In live server, force reload all (re-added/modified) static files.+        -- In statically generated site, do it only for CSS and JS files.+        guard $+          Ema.CLI.isLiveServer (modelCliAction model)+            || takeExtension fp `List.elem` [".css", ".js"]+        pure $ "?" <> tag++lookupMust :: FilePath -> Model -> UTCTime+lookupMust fp model =+  case Map.lookup fp (modelFiles model) of+    Just lastAccessed -> lastAccessed+    Nothing -> throw $ MissingStaticFile fp++newtype MissingStaticFile = MissingStaticFile FilePath+  deriving stock (Eq, Show)+  deriving anyclass (Exception)

@@ -0,0 +1,28 @@+module Ema.Route.Lib.File (+  FileRoute (..),+) where++import Ema.Route.Class (IsRoute (..))+import Ema.Route.Prism (+  toPrism_,+ )+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Optics.Core (coercedTo, only, (%))++{- | A type-level singleton route, whose encoding is given by the symbol parameter.++ FileRoute "foo.html" encodes to "foo.html".++ TODO: Can this type be simplified? See https://stackoverflow.com/q/72755053/55246+-}+newtype FileRoute (filename :: Symbol) = FileRoute ()+  deriving stock (Eq, Ord, Show, Generic)++instance KnownSymbol fn => IsRoute (FileRoute fn) where+  type RouteModel (FileRoute fn) = ()+  routePrism () =+    toPrism_ $+      only (symbolVal (Proxy @fn))+        % coercedTo+  routeUniverse () =+    [FileRoute ()]

@@ -0,0 +1,48 @@+module Ema.Route.Lib.Folder (+  FolderRoute (FolderRoute, unFolderRoute),+  prefixRoutePrism,+) where++import Data.Text qualified as T+import Ema.Route.Class (IsRoute (..))+import Ema.Route.Prism (Prism_, mapRoutePrism)+import Ema.Site (EmaSite (..), EmaStaticSite)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Optics.Core (coercedTo, prism', (%))+import System.FilePath ((</>))+import Text.Show (Show (show))++-- | A route that is prefixed at some URL prefix+newtype FolderRoute (prefix :: Symbol) r = FolderRoute {unFolderRoute :: r}+  deriving newtype (Eq, Ord, Generic)++instance (Show r, KnownSymbol prefix) => Show (FolderRoute prefix r) where+  show (FolderRoute r) = symbolVal (Proxy @prefix) <> "/:" <> Text.Show.show r++instance (IsRoute r, KnownSymbol prefix) => IsRoute (FolderRoute prefix r) where+  type RouteModel (FolderRoute prefix r) = RouteModel r+  routePrism = prefixRoutePrism @prefix @r $ routePrism @r+  routeUniverse m = FolderRoute <$> routeUniverse @r m++instance (EmaStaticSite r, KnownSymbol prefix) => EmaSite (FolderRoute prefix r) where+  type SiteArg (FolderRoute prefix r) = SiteArg r+  siteInput cliAct =+    siteInput @r cliAct+  siteOutput rp m r =+    siteOutput @r (rp % coercedTo) m (unFolderRoute r)++-- | Prefix the encoding of the given route prism.+prefixRoutePrism ::+  forall prefix r.+  KnownSymbol prefix =>+  (RouteModel r -> Prism_ FilePath r) ->+  (RouteModel r -> Prism_ FilePath (FolderRoute prefix r))+prefixRoutePrism =+  mapRoutePrism+    (prism' (prefix </>) stripPrefix)+    coercedTo+    id+  where+    prefix = symbolVal (Proxy @prefix)+    stripPrefix =+      fmap toString . T.stripPrefix (toText $ prefix <> "/") . toText

@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -Wno-orphans #-}++{- | Merging multiple Ema sites into one.++    This is implemented in using `sop-core`'s NS and NP types. Use as+    `MultiRoute '[MySite1, MySite2, ...]`.+-}+module Ema.Route.Lib.Multi (+  MultiRoute,+  MultiModel,+) where++import Data.SOP (I (..), NP (..), NS (..))+import Ema.Route.Class (IsRoute (..))+import Ema.Route.Prism+import Ema.Site (EmaSite (..), EmaStaticSite)+import Optics.Core (equality, iso, prism', (%))++{- | The merged site's route is represented as a n-ary sum (`NS`) of the+ sub-routes.+-}+type MultiRoute (rs :: [Type]) = NS I rs++type family MultiModel (rs :: [Type]) :: [Type] where+  MultiModel '[] = '[]+  MultiModel (r ': rs) = RouteModel r : MultiModel rs++type family MultiSiteArg (rs :: [Type]) :: [Type] where+  MultiSiteArg '[] = '[]+  MultiSiteArg (r ': rs) = SiteArg r : MultiSiteArg rs++instance IsRoute (MultiRoute '[]) where+  type RouteModel (MultiRoute '[]) = NP I '[]+  routePrism = impossiblePrism+    where+      impossiblePrism :: (NP I '[] -> Prism_ FilePath (MultiRoute '[]))+      impossiblePrism Nil =+        toPrism_ $ prism' (\case {}) (const Nothing)+  routeUniverse Nil = mempty++instance+  ( IsRoute r+  , IsRoute (MultiRoute rs)+  , RouteModel (MultiRoute rs) ~ NP I (MultiModel rs)+  ) =>+  IsRoute (MultiRoute (r ': rs))+  where+  type RouteModel (MultiRoute (r ': rs)) = NP I (RouteModel r ': MultiModel rs)+  routePrism =+    routePrism @r+      `nsRoutePrism` routePrism @(MultiRoute rs)+  routeUniverse (I m :* ms) =+    fmap (toNS . Left) (routeUniverse @r m)+      <> fmap (toNS . Right) (routeUniverse @(MultiRoute rs) ms)++instance EmaSite (MultiRoute '[]) where+  type SiteArg (MultiRoute '[]) = NP I '[]+  siteInput _ Nil = pure $ pure Nil+  siteOutput _ Nil = \case {}++instance+  ( EmaStaticSite r+  , EmaStaticSite (MultiRoute rs)+  , SiteArg (MultiRoute rs) ~ NP I (MultiSiteArg rs)+  , RouteModel (MultiRoute rs) ~ NP I (MultiModel rs)+  ) =>+  EmaSite (MultiRoute (r ': rs))+  where+  type SiteArg (MultiRoute (r ': rs)) = NP I (MultiSiteArg (r ': rs))+  siteInput cliAct (I i :* is) = do+    m <- siteInput @r cliAct i+    ms <- siteInput @(MultiRoute rs) cliAct is+    pure $ curry toNP <$> m <*> ms+  siteOutput rp (I m :* ms) =+    fromNS+      >>> either+        (siteOutput @r (rp % headRoute) m)+        (siteOutput @(MultiRoute rs) (rp % tailRoute) ms)+    where+      tailRoute =+        (prism' (toNS . Right) (fromNS >>> rightToMaybe))+      headRoute =+        (prism' (toNS . Left) (fromNS >>> leftToMaybe))++-- | Like `eitherRoutePrism` but uses sop-core types instead of Either/Product.+nsRoutePrism ::+  (a -> Prism_ FilePath r) ->+  (NP I as -> Prism_ FilePath (NS I rs)) ->+  (NP I (a ': as) -> Prism_ FilePath (NS I (r ': rs)))+nsRoutePrism a b =+  eitherRoutePrism a b+    & mapRoutePrism equality (iso toNS fromNS) fromNP++fromNP :: NP I (a ': as) -> (a, NP I as)+fromNP (I x :* y) = (x, y)++toNP :: (a, NP I as) -> NP I (a ': as)+toNP (x, y) = I x :* y++fromNS :: NS I (a ': as) -> Either a (NS I as)+fromNS = \case+  Z (I x) -> Left x+  S xs -> Right xs++toNS :: Either a (NS I as) -> NS I (a ': as)+toNS = either (Z . I) S

@@ -0,0 +1,56 @@+module Ema.Route.Prism (+  module X,++  -- * Handy encoders+  eitherRoutePrism,++  -- * Handy lenses+  htmlSuffixPrism,+  stringIso,+  showReadPrism,+) where++import Data.Text qualified as T+import Ema.Route.Prism.Check as X+import Ema.Route.Prism.Type as X+import Optics.Core (Iso', Prism', iso, preview, prism', review)++stringIso :: (ToString a, IsString a) => Iso' String a+stringIso = iso fromString toString++showReadPrism :: (Show a, Read a) => Prism' String a+showReadPrism = prism' show readMaybe++htmlSuffixPrism :: Prism' FilePath FilePath+htmlSuffixPrism = prism' (<> ".html") (fmap toString . T.stripSuffix ".html" . toText)++{- | Returns a new route `Prism_` that supports *either* of the input routes.++  The resulting route `Prism_`'s model type becomes the *product* of the input models.+-}+eitherRoutePrism ::+  (a -> Prism_ FilePath r1) ->+  (b -> Prism_ FilePath r2) ->+  ((a, b) -> Prism_ FilePath (Either r1 r2))+eitherRoutePrism enc1 enc2 (m1, m2) =+  toPrism_ $ eitherPrism (fromPrism_ $ enc1 m1) (fromPrism_ $ enc2 m2)++{- | Given two @Prism'@'s whose filepaths are distinct (ie., both @a@ and @b@+ encode to distinct filepaths), return a new @Prism'@ that combines both.++ If this distinctness property does not hold between the input @Prism'@'s, then+ the resulting @Prism'@ will not be lawful.+-}+eitherPrism :: Prism' FilePath a -> Prism' FilePath b -> Prism' FilePath (Either a b)+eitherPrism p1 p2 =+  prism'+    ( either+        (review p1)+        (review p2)+    )+    ( \fp ->+        asum+          [ Left <$> preview p1 fp+          , Right <$> preview p2 fp+          ]+    )

@@ -0,0 +1,93 @@+module Ema.Route.Prism.Check (+  checkRoutePrismGivenFilePath,+  checkRoutePrismGivenRoute,+) where++import Control.Monad.Writer (Writer, runWriter, tell)+import Data.Text qualified as T+import Ema.Route.Prism.Type (Prism_, fromPrism_)+import Optics.Core (Prism', preview, review)+import System.FilePath ((</>))++checkRoutePrismGivenRoute ::+  (HasCallStack, Eq r, Show r) =>+  (a -> Prism_ FilePath r) ->+  a ->+  r ->+  Either Text ()+checkRoutePrismGivenRoute enc a r =+  let s = review (fromPrism_ $ enc a) r+   in checkRoutePrism enc a r s++checkRoutePrismGivenFilePath ::+  (HasCallStack, Eq r, Show r) =>+  (a -> Prism_ FilePath r) ->+  a ->+  FilePath ->+  Either (r, [(FilePath, Text)]) (Maybe r)+checkRoutePrismGivenFilePath enc a s = do+  -- We should treat /foo, /foo.html and /foo/index.html as equivalent.+  let candidates = [s, s <> ".html", s </> "index.html"]+      rp = fromPrism_ $ enc a+  case asum (preview rp <$> candidates) of+    Nothing -> pure Nothing+    Just r -> do+      -- All candidates must be checked, and if even one passes - we let this+      -- route go through.+      let (failed, passed) =+            partitionEithers $+              candidates <&> \candidate ->+                case checkRoutePrism enc a r candidate of+                  Left err -> Left (candidate, err)+                  Right () -> Right ()+      if null passed+        then Left (r, failed)+        else Right (Just r)++checkRoutePrism :: (Eq r, Show r) => (a -> Prism_ FilePath r) -> a -> r -> FilePath -> Either Text ()+checkRoutePrism p a r s =+  let (valid, checkLog) =+        runWriter $ routePrismIsLawfulFor p a r s+   in if valid+        then Right ()+        else Left $ "Unlawful route prism for route value '" <> show r <> "'\n- " <> T.intercalate "\n- " checkLog++{- | Check if the route @Prism_@ is lawful.++  A route @Prism_@ is lawful if its conversions both the ways form an+  isomorphism for a given value.++  Returns a Writer reporting logs.+-}+routePrismIsLawfulFor ::+  forall ctx a.+  (Eq a, Show a) =>+  (ctx -> Prism_ FilePath a) ->+  ctx ->+  a ->+  FilePath ->+  Writer [Text] Bool+routePrismIsLawfulFor enc =+  prismIsLawfulFor . fromPrism_ . enc++prismIsLawfulFor ::+  forall s a.+  (Eq a, Eq s, Show a, ToText s) =>+  Prism' s a ->+  a ->+  s ->+  Writer [Text] Bool+prismIsLawfulFor p a s = do+  -- TODO: The logging here could be improved.+  -- log $ "Testing Partial ISO law for " <> show a <> " and " <> toText s+  let s' :: s = review p a+  -- log $ "Prism actual encoding: " <> toText s'+  let ma' :: Maybe a = preview p s'+  -- log $ "Decoding of that encoding: " <> show ma'+  unless (s == s') $+    log $ toText s <> " /= " <> toText s' <> " (encoding of '" <> show a <> "')"+  unless (Just a == ma') $+    log $ show (Just a) <> " /= " <> show ma' <> " (decoding of " <> toText s <> ")"+  pure $ (s == s') && (Just a == ma')+  where+    log = tell . one

@@ -0,0 +1,46 @@+module Ema.Route.Prism.Type where++import Optics.Core (A_Prism, Is, NoIx, Optic', Prism', castOptic, preview, prism', review, (%))++--  DerivingVia prevents us from directly using Prism' here+--  https://stackoverflow.com/q/71489589/55246++{- | Isomorphic to @Prism' s a@, but coercion-friendly.++ Use `fromPrism_` and `toPrism_` to convert between the optics @Prism'@ and this+ @Prism_@.+-}+type Prism_ s a = (a -> s, s -> Maybe a)++-- | Convert a `Prism_` to a @Prism'@.+fromPrism_ :: Prism_ s a -> Prism' s a+fromPrism_ = uncurry prism'++-- | Convert a @Prism'@ to a `Prism_`.+toPrism_ :: Prism' s a -> Prism_ s a+toPrism_ = review &&& preview++-- | map over the filepath, route and model of the given route prism.+mapRoutePrism ::+  (pr `Is` A_Prism, pf `Is` A_Prism) =>+  -- | How to transform the encoded `FilePath`+  Optic' pf NoIx FilePath FilePath ->+  -- | How to transform the decode route+  Optic' pr NoIx r1 r2 ->+  -- | How to transform (contramap) the resultant model+  (b -> a) ->+  -- | The route prism to fmap.+  (a -> Prism_ FilePath r1) ->+  (b -> Prism_ FilePath r2)+mapRoutePrism (castOptic -> fp) (castOptic -> rp) m enc =+  toPrism_ . cpmap fp rp m (fromPrism_ . enc)+  where+    cpmap ::+      forall a b c d x y.+      Prism' b a ->+      Prism' c d ->+      (y -> x) ->+      (x -> Prism' a c) ->+      (y -> Prism' b d)+    cpmap p q f r x =+      p % r (f x) % q

@@ -0,0 +1,77 @@+{-# LANGUAGE InstanceSigs #-}++module Ema.Route.Url (+  -- * Create URL from route+  routeUrl,+  routeUrlWith,+  UrlStrategy (..),+  urlToFilePath,+) where++import Data.Aeson (FromJSON (parseJSON), Value)+import Data.Aeson.Types (Parser)+import Data.Text qualified as T+import Network.URI.Slug qualified as Slug+import Optics.Core (Prism', review)++{- | Return the relative URL of the given route++ Note: when using relative URLs it is imperative to set the `<base>` URL to your+ site's base URL or path (typically just `/`). Otherwise you must accordingly+ make these URLs absolute yourself.+-}+routeUrlWith :: HasCallStack => UrlStrategy -> Prism' FilePath r -> r -> Text+routeUrlWith urlStrategy rp =+  relUrlFromPath . review rp+  where+    relUrlFromPath :: FilePath -> Text+    relUrlFromPath fp =+      case toString <$> T.stripSuffix (urlStrategySuffix urlStrategy) (toText fp) of+        Just htmlFp ->+          case nonEmpty (filepathToUrl htmlFp) of+            Nothing ->+              ""+            Just (removeLastIfOneOf ["index", "index.html"] -> partsSansIndex) ->+              T.intercalate "/" partsSansIndex+        Nothing ->+          T.intercalate "/" $ filepathToUrl fp+      where+        removeLastIfOneOf :: Eq a => [a] -> NonEmpty a -> [a]+        removeLastIfOneOf x xs =+          if last xs `elem` x+            then init xs+            else toList xs+        urlStrategySuffix = \case+          UrlPretty -> ".html"+          UrlDirect -> ""++filepathToUrl :: FilePath -> [Text]+filepathToUrl =+  fmap (Slug.encodeSlug . fromString @Slug.Slug . toString) . T.splitOn "/" . toText++urlToFilePath :: Text -> FilePath+urlToFilePath =+  toString . T.intercalate "/" . fmap (Slug.unSlug . Slug.decodeSlug) . T.splitOn "/"++-- | Like `routeUrlWith` but uses @UrlDirect@ strategy+routeUrl :: HasCallStack => Prism' FilePath r -> r -> Text+routeUrl =+  routeUrlWith UrlDirect++-- | How to produce URL paths from routes+data UrlStrategy+  = -- | Use pretty URLs. The route encoding "foo/bar.html" produces "foo/bar" as URL.+    UrlPretty+  | -- | Use filepaths as URLs. The route encoding "foo/bar.html" produces "foo/bar.html" as URL.+    UrlDirect+  deriving stock (Eq, Show, Ord, Generic)++instance FromJSON UrlStrategy where+  parseJSON val =+    f UrlPretty "pretty" val <|> f UrlDirect "direct" val+    where+      f :: UrlStrategy -> Text -> Value -> Parser UrlStrategy+      f c s v = do+        x <- parseJSON v+        guard $ x == s+        pure c

@@ -1,83 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}  module Ema.Server where  import Control.Concurrent.Async (race)-import Control.Exception (catch, try)+import Control.Exception (try) import Control.Monad.Logger-import Data.Default+import Data.FileEmbed import Data.LVar (LVar) import Data.LVar qualified as LVar import Data.Text qualified as T-import Ema.Asset-import Ema.Class (Ema (..))-import GHC.IO.Unsafe (unsafePerformIO)+import Ema.Asset (+  Asset (AssetGenerated, AssetStatic),+  Format (Html, Other),+ )+import Ema.CLI (Host (unHost))+import Ema.Route.Class (IsRoute (RouteModel, routePrism))+import Ema.Route.Prism (+  checkRoutePrismGivenFilePath,+  fromPrism_,+ )+import Ema.Route.Url (urlToFilePath)+import Ema.Site (EmaSite (siteOutput), EmaStaticSite) import NeatInterpolation (text) import Network.HTTP.Types qualified as H import Network.Wai qualified as Wai+import Network.Wai.Handler.Warp (Port) import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Handler.WebSockets qualified as WaiWs import Network.Wai.Middleware.Static qualified as Static import Network.WebSockets (ConnectionException) import Network.WebSockets qualified as WS-import System.FilePath ((</>))+import Optics.Core (review) import Text.Printf (printf) import UnliftIO (MonadUnliftIO)---- | Host string to start the server on.-newtype Host = Host {unHost :: Text}-  deriving newtype (Eq, Show, Ord, IsString)---- | Port number to bind the server on.-newtype Port = Port {unPort :: Int}-  deriving newtype (Eq, Show, Ord, Num, Read)--instance Default Host where-  def = "127.0.0.1"--instance Default Port where-  def = 8000+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception (catch)  runServerWithWebSocketHotReload ::-  forall model route m.-  ( Ema model route,-    Show route,-    MonadIO m,-    MonadUnliftIO m,-    MonadLoggerIO m+  forall r m.+  ( Show r+  , MonadIO m+  , MonadUnliftIO m+  , MonadLoggerIO m+  , Eq r+  , IsRoute r+  , EmaStaticSite r   ) =>   Host ->-  Port ->-  LVar model ->-  (model -> route -> Asset LByteString) ->+  Maybe Port ->+  LVar (RouteModel r) ->   m ()-runServerWithWebSocketHotReload host port model render = do-  let settings =+runServerWithWebSocketHotReload host mport model = do+  logger <- askLoggerIO+  let runM = flip runLoggingT logger+      settings =         Warp.defaultSettings-          & Warp.setPort (unPort port)           & Warp.setHost (fromString . toString . unHost $ host)-  logger <- askLoggerIO--  logInfoN "=============================================="-  logInfoN $ "Ema live server running: http://" <> unHost host <> ":" <> show port-  logInfoN "=============================================="-  liftIO $-    Warp.runSettings settings $-      assetsMiddleware $+      app =         WaiWs.websocketsOr           WS.defaultConnectionOptions-          (flip runLoggingT logger . wsApp)+          (runM . wsApp)           (httpApp logger)+      banner port = do+        logInfoNS "ema" "==============================================="+        logInfoNS "ema" $ "Ema live server RUNNING: http://" <> unHost host <> ":" <> show port+        logInfoNS "ema" "==============================================="+  liftIO $ warpRunSettings settings mport (runM . banner) app   where+    enc = routePrism @r+    -- Like Warp.runSettings but takes *optional* port. When no port is set, a+    -- free (random) port is used.+    warpRunSettings :: Warp.Settings -> Maybe Port -> (Port -> IO a) -> Wai.Application -> IO ()+    warpRunSettings settings mPort banner app = do+      case mPort of+        Nothing ->+          Warp.withApplicationSettings settings (pure app) $ \port -> do+            void $ banner port+            threadDelay maxBound+        Just port -> do+          void $ banner port+          Warp.runSettings (settings & Warp.setPort port) app     wsApp pendingConn = do       conn :: WS.Connection <- lift $ WS.acceptRequest pendingConn       logger <- askLoggerIO       lift $-        WS.withPingThread conn 30 (pure ()) $+        WS.withPingThread conn 30 pass $           flip runLoggingT logger $ do             subId <- LVar.addListener model             let log lvl (s :: Text) =-                  logWithoutLoc (toText @String $ printf "WS.Client.%.2d" subId) lvl s+                  logWithoutLoc (toText @String $ printf "ema.ws.%.2d" subId) lvl s             log LevelInfo "Connected"             let askClientForRoute = do                   msg :: Text <- liftIO $ WS.receiveData conn@@ -90,20 +104,23 @@                   pure $ routeFromPathInfo val pathInfo                 sendRouteHtmlToClient pathInfo s = do                   decodeRouteWithCurrentModel pathInfo >>= \case-                    Nothing ->+                    Left err -> do+                      log LevelError $ badRouteEncodingMsg err+                      liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse $ badRouteEncodingMsg err+                    Right Nothing ->                       liftIO $ WS.sendTextData conn $ emaErrorHtmlResponse decodeRouteNothingMsg-                    Just r -> do-                      case renderCatchingErrors logger s r of+                    Right (Just r) -> do+                      renderCatchingErrors s r >>= \case                         AssetStatic staticPath ->                           -- HACK: Websocket client should check for REDIRECT prefix.                           -- Not bothering with JSON to avoid having to JSON parse every HTML dump.                           liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText staticPath                         AssetGenerated Html html ->-                          liftIO $ WS.sendTextData conn $ html <> emaStatusHtml+                          liftIO $ WS.sendTextData conn $ html <> toLazy wsClientHtml                         AssetGenerated Other _s ->                           -- HACK: Websocket client should check for REDIRECT prefix.                           -- Not bothering with JSON to avoid having to JSON parse every HTML dump.-                          liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (encodeRoute s r)+                          liftIO $ WS.sendTextData conn $ "REDIRECT " <> toText (review (fromPrism_ $ enc s) r)                       log LevelDebug $ " ~~> " <> show r                 loop = flip runLoggingT logger $ do                   -- Notice that we @askClientForRoute@ in succession twice here.@@ -130,7 +147,7 @@                         sendRouteHtmlToClient mNextRoute =<< LVar.get model                         lift loop             liftIO (try loop) >>= \case-              Right () -> pure ()+              Right () -> pass               Left (connExc :: ConnectionException) -> do                 case connExc of                   WS.CloseRequest _ (decodeUtf8 -> reason) ->@@ -138,287 +155,106 @@                   _ ->                     log LevelError $ "Websocket error: " <> show connExc                 LVar.removeListener model subId-    assetsMiddleware =-      Static.static     httpApp logger req f = do       flip runLoggingT logger $ do         val <- LVar.get model         let path = Wai.pathInfo req             mr = routeFromPathInfo val path-        logInfoNS "HTTP" $ show path <> " as " <> show mr+        logInfoNS "ema.http" $ "GET " <> ("/" <> T.intercalate "/" path) <> " as " <> show mr         case mr of-          Nothing ->-            liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/plain")] $ encodeUtf8 decodeRouteNothingMsg-          Just r -> do-            case renderCatchingErrors logger val r of+          Left err -> do+            logErrorNS "App" $ badRouteEncodingMsg err+            let s = emaErrorHtmlResponse (badRouteEncodingMsg err) <> wsClientJS+            liftIO $ f $ Wai.responseLBS H.status500 [(H.hContentType, "text/html")] s+          Right Nothing -> do+            let s = emaErrorHtmlResponse decodeRouteNothingMsg <> wsClientJS+            liftIO $ f $ Wai.responseLBS H.status404 [(H.hContentType, "text/html")] s+          Right (Just r) -> do+            renderCatchingErrors val r >>= \case               AssetStatic staticPath -> do                 let mimeType = Static.getMimeType staticPath                 liftIO $ f $ Wai.responseFile H.status200 [(H.hContentType, mimeType)] staticPath Nothing               AssetGenerated Html html -> do-                let s = html <> emaStatusHtml <> wsClientShim+                let s = html <> toLazy wsClientHtml <> wsClientJS                 liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, "text/html")] s               AssetGenerated Other s -> do-                let mimeType = Static.getMimeType $ encodeRoute val r+                let mimeType = Static.getMimeType $ review (fromPrism_ $ enc val) r                 liftIO $ f $ Wai.responseLBS H.status200 [(H.hContentType, mimeType)] s-    renderCatchingErrors logger m r =-      unsafeCatch (render m r) $ \(err :: SomeException) ->-        unsafePerformIO $ do-          -- Log the error first.-          flip runLoggingT logger $ logErrorNS "App" $ show @Text err-          pure $-            AssetGenerated Html . emaErrorHtml $-              show @Text err+    renderCatchingErrors m r =+      catch (siteOutput (fromPrism_ $ enc m) m r) $ \(err :: SomeException) -> do+        -- Log the error first.+        logErrorNS "App" $ show @Text err+        pure $+          AssetGenerated Html . mkHtmlErrorMsg $+            show @Text err     routeFromPathInfo m =       decodeUrlRoute m . T.intercalate "/"-    -- 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)+    -- Decode an URL path into a route+    --+    -- This function is used only in live server. If the route is not+    -- isomoprhic, this returns a Left, with the mismatched encoding.+    decodeUrlRoute :: RouteModel r -> Text -> Either (BadRouteEncoding r) (Maybe r)+    decodeUrlRoute m (urlToFilePath -> s) = do+      case checkRoutePrismGivenFilePath enc m s of+        Left (r, log) -> Left $ BadRouteEncoding s r log+        Right mr -> Right mr  -- | A basic error response for displaying in the browser emaErrorHtmlResponse :: Text -> LByteString emaErrorHtmlResponse err =-  emaErrorHtml err <> emaStatusHtml+  mkHtmlErrorMsg err <> toLazy wsClientHtml -emaErrorHtml :: Text -> LByteString-emaErrorHtml s =-  encodeUtf8 $-    "<html><head><meta charset=\"UTF-8\"></head><body><h1>Ema App threw an exception</h1><pre style=\"border: 1px solid; padding: 1em 1em 1em 1em;\">"-      <> s-      <> "</pre><p>Once you fix the source of the error, this page will automatically refresh.</body>"+mkHtmlErrorMsg :: Text -> LByteString+mkHtmlErrorMsg s =+  encodeUtf8 . T.replace "MESSAGE" s . decodeUtf8 $ $(embedFile "www/ema-error.html") --- | Return the equivalent of WAI's @pathInfo@, from the raw path string--- (`document.location.pathname`) the browser sends us.+{- | 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 --- | 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 model (toString -> s) = do-  decodeRoute @model @route model s-    <|> decodeRoute @model @route model (s <> ".html")-    <|> decodeRoute @model @route model (s </> "index.html")- decodeRouteNothingMsg :: Text-decodeRouteNothingMsg = "Ema: 404 (decodeRoute returned Nothing)"+decodeRouteNothingMsg = "Ema: 404 (route decoding returned Nothing)" +data BadRouteEncoding r = BadRouteEncoding+  { _bre_urlFilePath :: FilePath+  , _bre_decodedRoute :: r+  , _bre_checkLog :: [(FilePath, Text)]+  }+  deriving stock (Show)++badRouteEncodingMsg :: Show r => BadRouteEncoding r -> Text+badRouteEncodingMsg BadRouteEncoding {..} =+  toText $+    "A route Prism' is unlawful.\n\nThe URL '" <> toText _bre_urlFilePath+      <> "' decodes to route '"+      <> show _bre_decodedRoute+      <> "', but it is not isomporphic on any of the allowed candidates: \n\n"+      <> T.intercalate+        "\n\n"+        ( _bre_checkLog <&> \(candidate, log) ->+            "## Candidate '" <> toText candidate <> "':\n" <> log+        )+      <> " \n\nYou should make the relevant routePrism lawful to fix this issue."++wsClientHtml :: ByteString+wsClientHtml = $(embedFile "www/ema-indicator.html")++wsClientJSShim :: Text+wsClientJSShim = decodeUtf8 $(embedFile "www/ema-shim.js")+ -- Browser-side JavaScript code for interacting with the Haskell server-wsClientShim :: LByteString-wsClientShim =+wsClientJS :: LByteString+wsClientJS =   encodeUtf8     [text|         <script type="module" src="https://cdn.jsdelivr.net/npm/morphdom@2.6.1/dist/morphdom-umd.min.js"></script>          <script type="module">--        function htmlToElem(html) {-          let temp = document.createElement('template');-          html = html.trim(); // Never return a space text node as a result-          temp.innerHTML = html;-          return temp.content.firstChild;-        };--        // Unlike setInnerHtml, this patches the Dom in place-        function setHtml(elm, html) {-          var htmlElem = htmlToElem(html);-          morphdom(elm, html);-          // Re-add <script> tags, because just DOM diff applying is not enough.-          reloadScripts(elm);-        };--        // FIXME: This doesn't reliably work across all JS.-        // See also the HACK below in one of the invocations.-        function reloadScripts(elm) {-          Array.from(elm.querySelectorAll("script")).forEach(oldScript => {-            const newScript = document.createElement("script");-            Array.from(oldScript.attributes)-              .forEach(attr => newScript.setAttribute(attr.name, attr.value));-            newScript.appendChild(document.createTextNode(oldScript.innerHTML));-            oldScript.parentNode.replaceChild(newScript, oldScript);-          });-        };--        // Ema Status indicator-        const messages = {-          connected: "Connected",-          reloading: "Reloading",-          connecting: "Connecting to the server",-          disconnected: "Disconnected - try reloading the window"-        };-        function setIndicators(connected, reloading, connecting, disconnected) {-          const is = { connected, reloading, connecting, disconnected }--          for (const i in is) {-            document.getElementById(`ema-$${i}`).style.display =-              is[i] ? "block" : "none"-            if(is[i])-              document.getElementById('ema-message').innerText = messages[i]-          };-          document.getElementById("ema-indicator").style.display = "block";-        };-        window.connected    = () => setIndicators(true,  false, false, false)-        window.reloading    = () => setIndicators(false, true,  false, false)-        window.connecting   = () => setIndicators(false, false, true,  false)-        window.disconnected = () => setIndicators(false, false, false, true)-        window.hideIndicator = () => {-          document.getElementById("ema-indicator").style.display = "none";-        };--        // Base URL path - for when the ema site isn't served at "/"-        const baseHref = document.getElementsByTagName("base")[0]?.href;-        const basePath = baseHref ? new URL(baseHref).pathname : "/";--        // Use TLS for websocket iff the current page is also served with TLS-        const wsProto = window.location.protocol === "https:" ? "wss://" : "ws://";-        const wsUrl = wsProto + window.location.host + basePath;--        // WebSocket logic: watching for server changes & route switching-        function init(reconnecting) {-          // The route current DOM is displaying-          let routeVisible = document.location.pathname;--          const verb = reconnecting ? "Reopening" : "Opening";-          console.log(`ema: $${verb} conn $${wsUrl} ...`);-          window.connecting();-          let ws = new WebSocket(wsUrl);--          function sendObservePath(path) {-            const relPath = path.startsWith(basePath) ? path.slice(basePath.length - 1) : path;-            console.debug(`ema: requesting $${relPath}`);-            ws.send(relPath);-          }--          // Call this, then the server will send update *once*. Call again for-          // continous monitoring.-          function watchCurrentRoute() {-            console.log(`ema: ⏿ Observing changes to $${document.location.pathname}`);-            sendObservePath(document.location.pathname);-          };--          function switchRoute(path) {-             console.log(`ema: → Switching to $${path}`);-             window.history.pushState({}, "", path);-             sendObservePath(path);-          }--          function handleRouteClicks(e) {-              const origin = e.target.closest("a");-              if (origin) {-                if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {-                  switchRoute(origin.pathname);-                  e.preventDefault();-                };-              }-            };-          // Intercept route click events, and ask server for its HTML whilst-          // managing history state.-          window.addEventListener(`click`, handleRouteClicks);--          ws.onopen = () => {-            console.log(`ema: ... connected!`);-            // window.connected();-            window.hideIndicator();-            if (!reconnecting) {-              // HACK: We have to reload <script>'s here on initial page load-              // here, so as to make Twind continue to function on the *next*-              // route change. This is not a problem with *subsequent* (ie. 2nd-              // or latter) route clicks, because those have already called-              // reloadScripts at least once.-              reloadScripts(document.documentElement);-            };-            watchCurrentRoute();-          };--          ws.onclose = () => {-            console.log("ema: reconnecting ..");-            window.removeEventListener(`click`, handleRouteClicks);-            window.reloading();-            // Reconnect after as small a time is possible, then retry again. -            // ghcid can take 1s or more to reboot. So ideally we need an-            // exponential retry logic.-            // -            // Note that a slow delay (200ms) may often cause websocket-            // connection error (ghcid hasn't rebooted yet), which cannot be-            // avoided as it is impossible to trap this error and handle it.-            // You'll see a big ugly error in the console.-            setTimeout(function () {init(true);}, 400);-          };--          ws.onmessage = evt => {-            if (evt.data.startsWith("REDIRECT ")) {-              console.log("ema: redirect");-              document.location.href = evt.data.slice("REDIRECT ".length);-            } else {-              console.log("ema: ✍ Patching DOM");-              setHtml(document.documentElement, evt.data);-              if (routeVisible != document.location.pathname) {-                // This is a new route switch; scroll up.-                window.scrollTo({ top: 0});-                routeVisible = document.location.pathname;-              } -              watchCurrentRoute();-            };-          };-          window.onbeforeunload = evt => { ws.close(); };-          window.onpagehide = evt => { ws.close(); };--          // When the user clicks the back button, resume watching the URL in-          // the addressback, which has the effect of loading it immediately.-          window.onpopstate = function(e) {-            watchCurrentRoute();-          };--          // API for user invocations -          window.ema = {-            switchRoute: switchRoute-          };-        };+        ${wsClientJSShim}                  window.onpageshow = function () { init(false) };         </script>     |]--emaStatusHtml :: LByteString-emaStatusHtml =-  encodeUtf8-    [text|-      <div class="absolute top-0 left-0 p-2" style="display: none;" id="ema-indicator">-        <div-          class="-            flex overflow-hidden items-center p-2 text-xs gap-2-            h-8 border-2 border-gray-200 bg-white rounded-full shadow-lg-            transition-[width,height] duration-500 ease-in-out w-8 hover:w-full-          "-          id="ema-status"-          title="Ema Status"-        >-          <div-            hidden-            class="flex-none w-3 h-3 bg-green-600 rounded-full"-            id="ema-connected"-          ></div>-          <div-            hidden-            class="flex-none w-3 h-3 rounded-full animate-spin bg-gradient-to-r from-blue-300 to-blue-600"-            id="ema-reloading"-          ></div>-          <div-            hidden-            class="flex-none w-3 h-3 bg-yellow-500 rounded-full"-            id="ema-connecting"-          >-            <div-              class="flex-none w-3 h-3 bg-yellow-500 rounded-full animate-ping"-            ></div>-          </div>-          <div-            hidden-            class="flex-none w-3 h-3 bg-red-500 rounded-full"-            id="ema-disconnected"-          ></div>-          <p class="whitespace-nowrap" id="ema-message"></p>-        </div>-      </div>-  |]

@@ -0,0 +1,74 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Ema.Site (+  EmaSite (..),+  EmaStaticSite,+) where++import Control.Monad.Logger (MonadLoggerIO)+import Data.Some (Some)+import Ema.Asset (Asset)+import Ema.CLI qualified as CLI+import Ema.Dynamic (Dynamic)+import Ema.Route.Class (IsRoute (RouteModel))+import Optics.Core (Prism')+import UnliftIO (MonadUnliftIO)++{- | Typeclass to orchestrate an Ema site++  Given a route `r` from the class of `IsRoute` types, instantiating EmaSite+  on it enables defining the site build pipeline as follows:++  @+  SiteArg -> siteInput -> Dynamic model --[r, model]--> siteOutput+  @++  - `SiteArg` is typically not used, but it can be used to pass command line+  arguments and other such settings.+  - `siteInput` returns a time-varying value (Dynamic) representing the data for+  your static site.+  - `siteOutput` takes this data model (oneshot value) and returns the generated+  content (usually HTML asset, per `SiteOutput`) for the given route.++  Finally, `Ema.App.runSite @r arg` (where `arg` is of type `SiteArg`) is run+  from the `main` entry point to run your Ema site.+-}+class IsRoute r => EmaSite r where+  -- | `SiteArg` is typically settings from the environment (config file, or+  --    command-line arguments) that your Dynamic-producing `siteInput` function+  --    consumes as argument.+  type SiteArg r :: Type++  -- By default Ema sites have no site arguments.+  type SiteArg r = ()++  -- | Type of the value returned by `siteOutput`. Usually `Asset LByteString`+  -- but it can be anything.+  type SiteOutput r :: Type++  type SiteOutput r = Asset LByteString++  -- | Get the model's time-varying value as a `Dynamic`.+  --+  --    If your model is not time-varying, use `pure` to produce a constant value.+  siteInput ::+    forall m.+    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>+    Some CLI.Action ->+    -- | The value passed by the programmer to `Ema.App.runSite`+    SiteArg r ->+    -- | Time-varying value of the model. If your model is not time-varying, use+    -- `pure` to produce a constant value.+    m (Dynamic m (RouteModel r))++  -- | Return the output (typically an `Asset`) for the given route and model.+  siteOutput ::+    forall m.+    (MonadIO m, MonadLoggerIO m) =>+    Prism' FilePath r ->+    RouteModel r ->+    r ->+    m (SiteOutput r)++-- | Like `EmaSite` but `SiteOutput` is a bytestring `Asset`.+type EmaStaticSite r = (EmaSite r, SiteOutput r ~ Asset LByteString)

@@ -0,0 +1,15 @@+{-# LANGUAGE UndecidableInstances #-}++module GHC.TypeLits.Extra where++import GHC.TypeLits (TypeError)++class Impossible where+  impossible :: a++{- | Like TypeError but suitable for use in type-classes to avoid `undefined`++ cf. https://stackoverflow.com/a/72783230/55246+-}+type family TypeErr t where+  TypeErr t = (TypeError t, Impossible)

@@ -0,0 +1,63 @@+{-# LANGUAGE UndecidableInstances #-}++module GHC.TypeLits.Extra.Symbol (+  StripPrefix,+  ToLower,+) where++import GHC.TypeLits (ConsSymbol, Symbol, UnconsSymbol)++-- | Strip `prefix` from `symbol`. Return `symbol` as-is if the prefix doesn't match.+type family StripPrefix (prefix :: Symbol) (symbol :: Symbol) :: Symbol where+  StripPrefix prefix symbol =+    FromMaybe+      symbol+      (StripPrefix' (UnconsSymbol prefix) (UnconsSymbol symbol))++-- | Strip `prefix` from `symbol`. Return Nothing if the prefix doesn't match.+type family StripPrefix' (prefix :: Maybe (Char, Symbol)) (symbol :: Maybe (Char, Symbol)) :: Maybe Symbol where+  StripPrefix' 'Nothing 'Nothing = 'Just ""+  StripPrefix' 'Nothing ( 'Just '(x, xs)) = 'Just (ConsSymbol x xs)+  StripPrefix' _p 'Nothing = 'Nothing+  StripPrefix' ( 'Just '(p, ps)) ( 'Just '(p, ss)) = StripPrefix' (UnconsSymbol ps) (UnconsSymbol ss)+  StripPrefix' ( 'Just '(p, ps)) ( 'Just '(_, ss)) = 'Nothing++type family ToLower (sym :: Symbol) :: Symbol where+  ToLower sym = ToLower' (UnconsSymbol sym)++type family ToLower' (pair :: Maybe (Char, Symbol)) :: Symbol where+  ToLower' 'Nothing = ""+  ToLower' ( 'Just '(c, cs)) = ConsSymbol (ToLowerC c) (ToLower' (UnconsSymbol cs))++type family ToLowerC (c :: Char) :: Char where+  ToLowerC 'A' = 'a'+  ToLowerC 'B' = 'b'+  ToLowerC 'C' = 'c'+  ToLowerC 'D' = 'd'+  ToLowerC 'E' = 'e'+  ToLowerC 'F' = 'f'+  ToLowerC 'G' = 'g'+  ToLowerC 'H' = 'h'+  ToLowerC 'I' = 'i'+  ToLowerC 'J' = 'j'+  ToLowerC 'K' = 'k'+  ToLowerC 'L' = 'l'+  ToLowerC 'M' = 'm'+  ToLowerC 'N' = 'n'+  ToLowerC 'O' = 'o'+  ToLowerC 'P' = 'p'+  ToLowerC 'Q' = 'q'+  ToLowerC 'R' = 'r'+  ToLowerC 'S' = 's'+  ToLowerC 'T' = 't'+  ToLowerC 'U' = 'u'+  ToLowerC 'V' = 'v'+  ToLowerC 'W' = 'w'+  ToLowerC 'X' = 'x'+  ToLowerC 'Y' = 'y'+  ToLowerC 'Z' = 'z'+  ToLowerC a = a++type family FromMaybe (def :: a) (maybe :: Maybe a) :: a where+  FromMaybe def 'Nothing = def+  FromMaybe def ( 'Just a) = a

@@ -0,0 +1,243 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Deriving where++import Data.Proxy (Proxy)+import Data.Text (Text)+import Ema.Route.Class+import Ema.Route.Generic+import Ema.Route.Generic.TH+import GHC.Generics qualified as GHC+import Generics.SOP qualified as SOP+import Text.RawString.QQ (r)++#define ENABLE_SPEC++----------------------------------------+-- Subroute verification+----------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data BadRoute = BR_1 Int String | BR_2 String+data M = M { m1 :: (), m2 :: () } deriving stock GHC.Generic++deriveGeneric ''BadRoute+-- Subroutes should not have constructors with multiple fields+-- Expect: MultiRoute: too many arguments+deriveIsRoute ''BadRoute [t|+    '[ WithModel M+     ]+  |]+#endif+#define ENABLE_SPEC++-----------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R_1 () | R_2 ()+deriveGeneric ''R+-- WithSubRoutes' list should not be shorter than number of route constructors+-- Expect:+{-+'WithSubRoutes' is missing subroutes for:++  '[()]+-}+deriveIsRoute ''R [t|+  '[ WithSubRoutes '[ () ] ]+  |]+#endif+#define ENABLE_SPEC++-----------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R_1 () | R_2 ()+deriveGeneric ''R+-- WithSubRoutes' list should not be longer than number of route constructors+-- Expect:+{-+'WithSubRoutes' has extra unnecessary types:++  '[Int]+-}+deriveIsRoute ''R [t|+  '[ WithSubRoutes '[ (), (), Int ] ]+  |]+#endif+#define ENABLE_SPEC++------------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R_1 Int | R_2+deriveGeneric ''R+-- constructors should either be empty or contain () when 'WithSubRoutes' specifies ()+-- Expect:+{-+A 'WithSubRoutes' entry is '()' instead of the expected:+Int+-}+deriveIsRoute ''R [t|+  '[ WithSubRoutes '[ (), () ] ]+  |]+#endif+#define ENABLE_SPEC++-------------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R_1 | R_2 +deriveGeneric ''R+-- subroute types that are nonisomorphic to what is specified in 'WithSubRoutes' should be illegal+-- Expect:+{-+Couldn't match representation of type ‘()’ with that of ‘Bool’+  arising from a use of ‘routePrism’+-}+deriveIsRoute ''R [t|+  ' [ WithSubRoutes '[ (), Bool] ]+  |]+#endif+#define ENABLE_SPEC++-------------------------------------------++-- subroute types that are the same as what is specified in 'WithSubRoutes' should typecheck"+data RSubIso = RSubIso_1 | RSubIso_2+deriveGeneric ''RSubIso+deriveIsRoute+  ''RSubIso+  [t|+    '[WithSubRoutes '[(), ()]]+    |]++-------------------------------------------++-- FIXME: This test is broken.+#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+routeSpec "subroute types that are an unwrapped representation of what is specified in 'WithSubRoutes' should typecheck | ( empty constructor <-> () ) special case"+  (niceRoute ''() ''())+  [t|+    '[ WithModel (NiceNamedM () ())+     , WithSubRoutes '[ (), PlainR_NiceNamedM ]+     ]+  |]+  [r|+  |]+#endif+#define ENABLE_SPEC++-------------------------------------------++-- Subroute types that are an unwrapped representation of what is specified in+-- 'WithSubRoutes' should typecheck | (wrapper deriving /newtype/ GHC.Generic)+-- case"+data RSubNewtype = RSubNewtype_1 | RSubNewtype_2+deriveGeneric ''RSubNewtype+newtype WrapNewtype a = WrapNewtype a+  deriving newtype (GHC.Generic, IsRoute)+deriveIsRoute+  ''RSubNewtype+  [t|+    '[ WithSubRoutes '[(), WrapNewtype ()]+     ]+    |]++-------------------------------------------+-- Submodel verification+-------------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R1 | R2 +deriveGeneric ''R +data M = M { m1 :: (), m2 :: () } deriving stock GHC.Generic+-- Submodel selectors should not be less than number of subroutes+-- Expect:+{-+'WithSubModels' is missing submodel types:+  '[()]+-}+deriveIsRoute ''R +  [t|+    '[ WithModel M+     , WithSubModels '[ Proxy "m1" ]+     ]+  |]+#endif+#define ENABLE_SPEC++-------------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R1 | R2 +deriveGeneric ''R +data M = M { m1 :: (), m2 :: () }+  deriving stock GHC.Generic+-- submodel selectors should not outnumber number of subroutes+-- Expect:+{-+'WithSubModels' has extra unnecessary types:++  '[Proxy "m2"]+-}+deriveIsRoute ''R+  [t|+    '[ WithModel M+     , WithSubModels '[ Proxy "m1", Proxy "m2", Proxy "m2" ]+     ]+  |]+#endif+#define ENABLE_SPEC++-------------------------------------------+data RSubMSelf = RSubMSelf1 | RSubMSelf2 RSubMSelf+  deriving stock (GHC.Generic)+deriveGeneric ''RSubMSelf+data MSelf = MSelf {mself1 :: (), mself2 :: ()}+  deriving stock (GHC.Generic)++-- submodel type selectors be able to reference the model itself if they are of the same type+deriveIsRoute+  ''RSubMSelf+  [t|+    '[ WithModel MSelf+     , WithSubModels '[Proxy "mself1", MSelf]+     ]+    |]++-------------------------------------------++#undef ENABLE_SPEC+#ifdef ENABLE_SPEC+data R = R1 | R2+deriveGeneric ''R+data M = M { m1 :: (), m2 :: () }+  deriving stock GHC.Generic+-- submodel type selectors must, at a minimum, refer to a model field of a matching type+-- Expect:+{-+Couldn't match type ‘Bool’ with ‘()’+-}+deriveIsRoute ''R+  [t|+    '[ WithModel M+     , WithSubModels '[ Proxy "m1", Bool ]+     ]+  |]+#endif+#define ENABLE_SPEC++-----------------------------------------

@@ -0,0 +1,5 @@+module Main where++-- | Filler module so cabal will be happy that there's a main-is+main :: IO ()+main = pure ()

@@ -0,0 +1,16 @@+<html lang="en">++<head>+    <meta charset="UTF-8">+    <meta name="viewport" content="width=device-width, initial-scale=1" />+    <title>Ema App exception</title>+</head>++<body class="overflow-y: scroll;">+    <h1>Ema App threw an exception</h1>+    <pre+        style="font-family: monospace; border: 1px solid; padding: 1em 1em 1em 1em; overflow-wrap: anywhere;">MESSAGE</pre>+    <p>Once you fix the source of the error, this page will automatically refresh.+</body>++</html>

@@ -0,0 +1,103 @@+<!-- +The inline CSS here is roughly analogous to the ones generated by Tailwind.+See the original version based on Tailwind`: https://gist.github.com/srid/2471813953a6df9b24909b9bb1d3cd2b+-->++<div style="+  display: none;+  position: absolute;+  top: 0px;+  left: 0px;+  padding: 0.5rem;+  font-size: 12px;+  line-height: 18px;+  tab-size: 4;+  text-size-adjust: 100%;+" id="ema-indicator">+  <div style="+    display: flex;+    overflow: hidden;+    font-size: 0.75rem;+    align-items: center;+    gap: 0.5rem;+    padding: 0.5rem;+    height: 2rem;+    width: 2rem;+    box-sizing: border-box;+    border-style: solid;+    border-width: 2px;+    border-color: rgb(229 231 235);+    background-color: rgb(255 255 255);+    border-radius: 9999px;+    box-shadow: 0 10px 15px -3px rgb(0 0 0 / 0.1), 0 4px 6px -4px rgb(0 0 0 / 0.1);+    transition-property: width, height;+    transition-duration: 500ms;+      transition-timing-function: cubic-bezier(0.4, 0, 0.2, 1);+  " onMouseOver="this.style.width='100%'" onMouseOut="this.style.width='2rem'" id="ema-status" title="Ema Status">+    <div hidden style="+      flex: none;+      width: 0.75rem;+      height: 0.75rem;+      background-color: rgb(22 163 74);+      border-radius: 9999px;+    " id="ema-connected"></div>+    <div hidden style="+      flex: none;+      width: 0.75rem;+      height: 0.75rem;+      border-radius: 9999px;+        animation: spin 1s linear infinite;+      background-image: linear-gradient(to right, var(--tw-gradient-stops));+      --tw-gradient-from: #93c5fd;+      --tw-gradient-stops: var(--tw-gradient-from), var(--tw-gradient-to);+      --tw-gradient-to: #2563eb;+    " id="ema-reloading">+      <style>+        @keyframes spin {+          from {+            transform: rotate(0deg);+          }++          to {+            transform: rotate(360deg);+          }+        }+      </style>+    </div>+    <div hidden style="+      flex: none;+      width: 0.75rem;+      height: 0.75rem;+      border-radius: 9999px;+        background-color: rgb(234 179 8);+    " id="ema-connecting">+      <div style="+        flex: none;+        width: 0.75rem;+        height: 0.75rem;+        border-radius: 9999px;+        background-color: rgb(234 179 8);+        animation: ping 1s cubic-bezier(0, 0, 0.2, 1) infinite;+      ">+        <style>+          @keyframes ping {++            75%,+            100% {+              transform: scale(2);+              opacity: 0;+            }+          }+        </style>+      </div>+    </div>+    <div hidden style="+      flex: none;+      width: 0.75rem;+      height: 0.75rem;+      border-radius: 9999px;+      background-color: rgb(239 68 68);+    " id="ema-disconnected"></div>+    <p style="white-space: nowrap;" id="ema-message"></p>+  </div>+</div>

@@ -0,0 +1,186 @@+function htmlToElem(html) {+    let temp = document.createElement('template');+    html = html.trim(); // Never return a space text node as a result+    temp.innerHTML = html;+    return temp.content.firstChild;+};++// Unlike setInnerHtml, this patches the Dom in place+function setHtml(elm, html) {+    var htmlElem = htmlToElem(html);+    window.dispatchEvent(new Event('EMABeforeMorphDOM'));+    morphdom(elm, html);+    window.dispatchEvent(new Event('EMABeforeScriptReload'));+    // Re-add <script> tags, because just DOM diff applying is not enough.+    reloadScripts(elm);+    window.dispatchEvent(new Event('EMAHotReload'));+};++// FIXME: This doesn't reliably work across all JS.+// See also the HACK below in one of the invocations.+function reloadScripts(elm) {+    Array.from(elm.querySelectorAll("script")).forEach(oldScript => {+        const newScript = document.createElement("script");+        Array.from(oldScript.attributes)+            .forEach(attr => newScript.setAttribute(attr.name, attr.value));+        newScript.appendChild(document.createTextNode(oldScript.innerHTML));+        oldScript.parentNode.replaceChild(newScript, oldScript);+    });+};++// Ema Status indicator+const messages = {+    connected: "Connected",+    reloading: "Reloading",+    connecting: "Connecting to the server",+    disconnected: "Disconnected - try reloading the window"+};+function setIndicators(connected, reloading, connecting, disconnected) {+    const is = { connected, reloading, connecting, disconnected }++    for (const i in is) {+        document.getElementById(`ema-${i}`).style.display =+            is[i] ? "block" : "none"+        if (is[i])+            document.getElementById('ema-message').innerText = messages[i]+    };+    document.getElementById("ema-indicator").style.display = "block";+};+window.connected = () => setIndicators(true, false, false, false)+window.reloading = () => setIndicators(false, true, false, false)+window.connecting = () => setIndicators(false, false, true, false)+window.disconnected = () => setIndicators(false, false, false, true)+window.hideIndicator = () => {+    document.getElementById("ema-indicator").style.display = "none";+};++// Base URL path - for when the ema site isn't served at "/"+const baseHref = document.getElementsByTagName("base")[0]?.href;+const basePath = baseHref ? new URL(baseHref).pathname : "/";++// Use TLS for websocket iff the current page is also served with TLS+const wsProto = window.location.protocol === "https:" ? "wss://" : "ws://";+const wsUrl = wsProto + window.location.host + basePath;++// WebSocket logic: watching for server changes & route switching+function init(reconnecting) {+    // The route current DOM is displaying+    let routeVisible = document.location.pathname;++    const verb = reconnecting ? "Reopening" : "Opening";+    console.log(`ema: ${verb} conn ${wsUrl} ...`);+    window.connecting();+    let ws = new WebSocket(wsUrl);++    function sendObservePath(path) {+        const relPath = path.startsWith(basePath) ? path.slice(basePath.length - 1) : path;+        console.debug(`ema: requesting ${relPath}`);+        ws.send(relPath);+    }++    // Call this, then the server will send update *once*. Call again for+    // continous monitoring.+    function watchCurrentRoute() {+        console.log(`ema: ⏿ Observing changes to ${document.location.pathname}`);+        sendObservePath(document.location.pathname);+    };++    function switchRoute(path, hash = "") {+        console.log(`ema: → Switching to ${path + hash}`);+        window.history.pushState({}, "", path + hash);+        sendObservePath(path);+    }++    function scrollToAnchor(hash) {+        console.log(`ema: Scroll to ${hash}`)+        var el = document.querySelector(hash);+        if (el !== null) {+            el.scrollIntoView({ behavior: 'smooth' });+        }+    };++    function handleRouteClicks(e) {+        const origin = e.target.closest("a");+        if (origin) {+            if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {+                if (origin.getAttribute("href").startsWith("#")) {+                    // Switching to local anchor+                    window.history.pushState({}, "", window.location.pathname + origin.hash);+                    scrollToAnchor(window.location.hash);+                    e.preventDefault();+                } else {+                    // Switching to another route+                    switchRoute(origin.pathname, origin.hash);+                    e.preventDefault();+                }+            };+        }+    };+    // Intercept route click events, and ask server for its HTML whilst+    // managing history state.+    window.addEventListener(`click`, handleRouteClicks);++    ws.onopen = () => {+        console.log(`ema: ... connected!`);+        // window.connected();+        window.hideIndicator();+        if (!reconnecting) {+            // HACK: We have to reload <script>'s here on initial page load+            // here, so as to make Twind continue to function on the *next*+            // route change. This is not a problem with *subsequent* (ie. 2nd+            // or latter) route clicks, because those have already called+            // reloadScripts at least once.+            reloadScripts(document.documentElement);+        };+        watchCurrentRoute();+    };++    ws.onclose = () => {+        console.log("ema: reconnecting ..");+        window.removeEventListener(`click`, handleRouteClicks);+        window.reloading();+        // Reconnect after as small a time is possible, then retry again. +        // ghcid can take 1s or more to reboot. So ideally we need an+        // exponential retry logic.+        // +        // Note that a slow delay (200ms) may often cause websocket+        // connection error (ghcid hasn't rebooted yet), which cannot be+        // avoided as it is impossible to trap this error and handle it.+        // You'll see a big ugly error in the console.+        setTimeout(function () { init(true); }, 400);+    };++++    ws.onmessage = evt => {+        if (evt.data.startsWith("REDIRECT ")) {+            console.log("ema: redirect");+            document.location.href = evt.data.slice("REDIRECT ".length);+        } else {+            console.log("ema: ✍ Patching DOM");+            setHtml(document.documentElement, evt.data);+            if (routeVisible != document.location.pathname) {+                // This is a new route switch; scroll up.+                window.scrollTo({ top: 0 });+                routeVisible = document.location.pathname;+            }+            if (window.location.hash) {+                scrollToAnchor(window.location.hash);+            }+            watchCurrentRoute();+        };+    };+    window.onbeforeunload = evt => { ws.close(); };+    window.onpagehide = evt => { ws.close(); };++    // When the user clicks the back button, resume watching the URL in+    // the addressback, which has the effect of loading it immediately.+    window.onpopstate = function (e) {+        watchCurrentRoute();+    };++    // API for user invocations +    window.ema = {+        switchRoute: switchRoute+    };+};