[](https://hackage.haskell.org/package/ema)
-[](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 Ctrl+Shift+B 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
diff --git a/ema.cabal b/ema.cabal
--- a/ema.cabal
+++ b/ema.cabal
@@ -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
diff --git a/src/Ema.hs b/src/Ema.hs
--- a/src/Ema.hs
+++ b/src/Ema.hs
@@ -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
diff --git a/src/Ema/App.hs b/src/Ema/App.hs
--- a/src/Ema/App.hs
+++ b/src/Ema/App.hs
@@ -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 ())
diff --git a/src/Ema/Asset.hs b/src/Ema/Asset.hs
--- a/src/Ema/Asset.hs
+++ b/src/Ema/Asset.hs
@@ -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)
diff --git a/src/Ema/CLI.hs b/src/Ema/CLI.hs
--- a/src/Ema/CLI.hs
+++ b/src/Ema/CLI.hs
@@ -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
diff --git a/src/Ema/Class.hs b/src/Ema/Class.hs
deleted file mode 100644
--- a/src/Ema/Class.hs
+++ /dev/null
@@ -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 ()
diff --git a/src/Ema/Dynamic.hs b/src/Ema/Dynamic.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Dynamic.hs
@@ -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
+ )
+ )
diff --git a/src/Ema/Example/Common.hs b/src/Ema/Example/Common.hs
--- a/src/Ema/Example/Common.hs
+++ b/src/Ema/Example/Common.hs
@@ -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
diff --git a/src/Ema/Example/Ex00_Hello.hs b/src/Ema/Example/Ex00_Hello.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex00_Hello.hs
@@ -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 "Hello, Ema"
+
+main :: IO ()
+main = void $ Ema.runSite @Route ()
diff --git a/src/Ema/Example/Ex01_Basic.hs b/src/Ema/Example/Ex01_Basic.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex01_Basic.hs
@@ -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 ()
diff --git a/src/Ema/Example/Ex01_HelloWorld.hs b/src/Ema/Example/Ex01_HelloWorld.hs
deleted file mode 100644
--- a/src/Ema/Example/Ex01_HelloWorld.hs
+++ /dev/null
@@ -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 $ "Hello, from " <> speaker
diff --git a/src/Ema/Example/Ex02_Basic.hs b/src/Ema/Example/Ex02_Basic.hs
deleted file mode 100644
--- a/src/Ema/Example/Ex02_Basic.hs
+++ /dev/null
@@ -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')
diff --git a/src/Ema/Example/Ex02_Clock.hs b/src/Ema/Example/Ex02_Clock.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex02_Clock.hs
@@ -0,0 +1,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)
diff --git a/src/Ema/Example/Ex03_Clock.hs b/src/Ema/Example/Ex03_Clock.hs
deleted file mode 100644
--- a/src/Ema/Example/Ex03_Clock.hs
+++ /dev/null
@@ -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)
diff --git a/src/Ema/Example/Ex03_Store.hs b/src/Ema/Example/Ex03_Store.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex03_Store.hs
@@ -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)
diff --git a/src/Ema/Example/Ex04_Multi.hs b/src/Ema/Example/Ex04_Multi.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex04_Multi.hs
@@ -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
diff --git a/src/Ema/Example/Ex05_MultiRoute.hs b/src/Ema/Example/Ex05_MultiRoute.hs
new file mode 100644
--- /dev/null
+++ b/src/Ema/Example/Ex05_MultiRoute.hs
@@ -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
diff --git a/src/Ema/Generate.hs b/src/Ema/Generate.hs
--- a/src/Ema/Generate.hs
+++ b/src/Ema/Generate.hs
@@ -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)
diff --git a/src/Ema/Route.hs b/src/Ema/Route.hs
deleted file mode 100644
--- a/src/Ema/Route.hs
+++ /dev/null
@@ -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 `" - <> s - <> "
Once you fix the source of the error, this page will automatically refresh." +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| |] - -emaStatusHtml :: LByteString -emaStatusHtml = - encodeUtf8 - [text| -
- |] diff --git a/src/Ema/Site.hs b/src/Ema/Site.hs new file mode 100644 --- /dev/null +++ b/src/Ema/Site.hs @@ -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) diff --git a/src/GHC/TypeLits/Extra.hs b/src/GHC/TypeLits/Extra.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Extra.hs @@ -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) diff --git a/src/GHC/TypeLits/Extra/Symbol.hs b/src/GHC/TypeLits/Extra/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/GHC/TypeLits/Extra/Symbol.hs @@ -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 diff --git a/test/type-errors/Deriving.hs b/test/type-errors/Deriving.hs new file mode 100644 --- /dev/null +++ b/test/type-errors/Deriving.hs @@ -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 + +----------------------------------------- diff --git a/test/type-errors/Spec.hs b/test/type-errors/Spec.hs new file mode 100644 --- /dev/null +++ b/test/type-errors/Spec.hs @@ -0,0 +1,5 @@ +module Main where + +-- | Filler module so cabal will be happy that there's a main-is +main :: IO () +main = pure () diff --git a/www/ema-error.html b/www/ema-error.html new file mode 100644 --- /dev/null +++ b/www/ema-error.html @@ -0,0 +1,16 @@ + + + + + +MESSAGE+
Once you fix the source of the error, this page will automatically refresh. + + + diff --git a/www/ema-indicator.html b/www/ema-indicator.html new file mode 100644 --- /dev/null +++ b/www/ema-indicator.html @@ -0,0 +1,103 @@ + + +
diff --git a/www/ema-shim.js b/www/ema-shim.js new file mode 100644 --- /dev/null +++ b/www/ema-shim.js @@ -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