ema 0.4.0.0 → 0.6.0.0

raw patch · 19 files changed

+140/−467 lines, 19 filesdep +url-slugdep −commonmarkdep −commonmark-extensionsdep −commonmark-pandocPVP ok

version bump matches the API change (PVP)

Dependencies added: url-slug

Dependencies removed: commonmark, commonmark-extensions, commonmark-pandoc, megaparsec, pandoc-types, parsec, parser-combinators, unicode-transforms, unionmount, uri-encode, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• ema.cabal +37/−30
• src/Ema.hs +0/−3
• src/Ema/App.hs +4/−9
• src/Ema/Asset.hs +2/−5
• src/Ema/CLI.hs +1/−5
• src/Ema/Class.hs +0/−1
• src/Ema/Example/Common.hs +37/−0
• src/Ema/Example/Ex01_HelloWorld.hs +0/−2
• src/Ema/Example/Ex02_Basic.hs +11/−15
• src/Ema/Example/Ex03_Clock.hs +10/−13
• src/Ema/Generate.hs +2/−2
• src/Ema/Helper/Blaze.hs +0/−93
• src/Ema/Helper/FileSystem.hs +0/−9
• src/Ema/Helper/Markdown.hs +0/−139
• src/Ema/Helper/PathTree.hs +0/−78
• src/Ema/Route.hs +7/−10
• src/Ema/Route/Slug.hs +0/−38
• src/Ema/Server.hs +17/−15

@@ -1,5 +1,17 @@ # Revision history for ema +## 0.6.0.0 -- 2022-02-05++- Websocket API: Add `ema.switchRoute` to switch to other routes in live server.+- Smaller core: remove helpers and examples (examples can be enabled by a flag)+  - Helpers+    - `Ema.Helpers.PathTree` moved to separate package *pathtree*.+    - `Ema.Helpers.FileSystem` moved to separate package *unionmount*.+    - `Ema.Helpers.Markdown` moved to separate package *commonmark-simple*.+    - `Ema.Helpers.Blaze` is no more. See `ema-template` if you need a ready made template using blaze HTML and TailwindCSS.+  - Examples `with-examples` cabal flag is made False by default. Examples are not exposed modules.+  - `Ema.Route.Slug` moved to separate package *url-slug*+ ## 0.4.0.0 -- 2022-01-19  - Pin TailwindCSS to 2.x, because the 3.x broke our CDN url

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               ema-version:            0.4.0.0+version:            0.6.0.0 license:            AGPL-3.0-only copyright:          2021 Sridhar Ratnakumar maintainer:         srid@srid.ca@@ -22,11 +22,7 @@  flag with-examples   description: Include examples and their dependencies-  default:     True--flag with-helpers-  description: Include helper modules based on blaze-html-  default:     True+  default:     False  library   -- Modules included in this executable, other than Main.@@ -54,33 +50,20 @@     , optparse-applicative     , relude                  >=0.7      && <1.0     , text-    , unicode-transforms-    , unionmount     , unliftio-    , uri-encode+    , url-slug     , wai     , wai-middleware-static     , wai-websockets     , warp     , websockets -  if (flag(with-helpers) || flag(with-examples))+  if flag(with-examples)     build-depends:       , blaze-html       , blaze-markup-      , commonmark-      , commonmark-extensions-      , commonmark-pandoc-      , megaparsec-      , pandoc-types-      , parsec-      , parser-combinators       , time-      , yaml -    if flag(with-examples)-      build-depends: time-   mixins:     base hiding (Prelude),     relude (Relude as Prelude, Relude.Container.One),@@ -88,41 +71,65 @@    ghc-options:     -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    exposed-modules:     Ema     Ema.CLI -  if (flag(with-helpers) || flag(with-examples))-    exposed-modules:-      Ema.Helper.Blaze-      Ema.Helper.FileSystem-      Ema.Helper.Markdown-      Ema.Helper.PathTree-   other-modules:     Ema.App     Ema.Asset     Ema.Class     Ema.Generate     Ema.Route-    Ema.Route.Slug     Ema.Server    if flag(with-examples)-    exposed-modules:+    other-modules:+      Ema.Example.Common       Ema.Example.Ex01_HelloWorld       Ema.Example.Ex02_Basic       Ema.Example.Ex03_Clock

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeApplications #-}- module Ema   ( module X,   )@@ -9,7 +7,6 @@ import Ema.Asset as X import Ema.Class as X import Ema.Route as X-import Ema.Route.Slug as X import Ema.Server as X   ( emaErrorHtmlResponse,   )

@@ -1,8 +1,3 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}- module Ema.App   ( runEma,     runEmaPure,@@ -20,14 +15,14 @@   ) import Data.Dependent.Sum (DSum ((:=>))) import Data.LVar (LVar)-import qualified Data.LVar as LVar+import Data.LVar qualified as LVar import Data.Some import Ema.Asset (Asset (AssetGenerated), Format (Html)) import Ema.CLI (Cli)-import qualified Ema.CLI as CLI+import Ema.CLI qualified as CLI import Ema.Class (Ema)-import qualified Ema.Generate as Generate-import qualified Ema.Server as Server+import Ema.Generate qualified as Generate+import Ema.Server qualified as Server import System.Directory (getCurrentDirectory) import UnliftIO   ( BufferMode (BlockBuffering, LineBuffering),

@@ -1,6 +1,3 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeApplications #-}- module Ema.Asset where  -- | The type of assets that can be bundled in a static site.@@ -12,7 +9,7 @@     AssetStatic FilePath   | -- | A file whose contents are generated at runtime by user code.     AssetGenerated Format a-  deriving (Eq, Show, Ord, Generic)+  deriving stock (Eq, Show, Ord, Generic)  data Format = Html | Other-  deriving (Eq, Show, Ord, Generic)+  deriving stock (Eq, Show, Ord, Generic)

@@ -1,10 +1,6 @@ {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}  module Ema.CLI where @@ -36,7 +32,7 @@ data Cli = Cli   { action :: (Some Action)   }-  deriving (Eq, Show)+  deriving stock (Eq, Show)  cliParser :: Parser Cli cliParser = do

@@ -1,6 +1,5 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeApplications #-}  module Ema.Class where 

@@ -0,0 +1,37 @@+module Ema.Example.Common+  ( tailwindLayout,+  )+where++import Text.Blaze.Html.Renderer.Utf8 qualified as RU+import Text.Blaze.Html5 ((!))+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A++-- | A simple and off-the-shelf layout using Tailwind CSS+tailwindLayout :: H.Html -> H.Html -> LByteString+tailwindLayout h b =+  layoutWith "en" "UTF-8" (tailwind2ShimCdn >> h) $+    -- The "overflow-y-scroll" makes the scrollbar visible always, so as to+    -- avoid janky shifts when switching to routes with suddenly scrollable content.+    H.body ! A.class_ "overflow-y-scroll" $ b+  where+    -- A general layout+    layoutWith :: H.AttributeValue -> H.AttributeValue -> H.Html -> H.Html -> LByteString+    layoutWith lang encoding appHead appBody = RU.renderHtml $ do+      H.docType+      H.html ! A.lang lang $ do+        H.head $ do+          H.meta ! A.charset encoding+          -- This makes the site mobile friendly by default.+          H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"+          appHead+        appBody++    -- Loads full tailwind CSS from CDN (not good for production)+    tailwind2ShimCdn :: H.Html+    tailwind2ShimCdn =+      H.link+        ! A.href "https://unpkg.com/tailwindcss@2/dist/tailwind.min.css"+        ! A.rel "stylesheet"+        ! A.type_ "text/css"

@@ -1,5 +1,3 @@-{-# LANGUAGE TypeApplications #-}- -- | The simplest Ema site possible. -- -- A site with one route (index) that displays content generated from pure

@@ -1,24 +1,20 @@-{-# LANGUAGE TypeApplications #-}- -- | A very simple site with two routes, and HTML rendered using Blaze DSL module Ema.Example.Ex02_Basic where  import Control.Concurrent (threadDelay)-import qualified Data.LVar as LVar-import Data.Some (Some (..))+import Data.LVar qualified as LVar import Ema (Ema (..))-import qualified Ema-import qualified Ema.CLI-import qualified Ema.CLI as CLI-import qualified Ema.Helper.Blaze as EB+import Ema qualified+import Ema.CLI qualified as CLI+import Ema.Example.Common (tailwindLayout) import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A  data Route   = Index   | About-  deriving (Show, Enum, Bounded)+  deriving stock (Show, Enum, Bounded)  newtype Model = Model {unModel :: Text} @@ -35,14 +31,14 @@ main :: IO () main = do   void $-    Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \act model -> do+    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 :: Some Ema.CLI.Action -> Model -> Route -> LByteString-render emaAction model r =-  EB.twindLayout emaAction (H.title "Basic site" >> H.base ! A.href "/") $+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

@@ -1,4 +1,3 @@-{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | A very simple site with routes, but based on dynamically changing values@@ -10,22 +9,20 @@ module Ema.Example.Ex03_Clock where  import Control.Concurrent (threadDelay)-import qualified Data.LVar as LVar+import Data.LVar qualified as LVar import Data.List ((!!))-import Data.Some (Some) import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Ema (Ema (..))-import qualified Ema-import qualified Ema.CLI-import qualified Ema.Helper.Blaze as EB+import Ema qualified+import Ema.Example.Common (tailwindLayout) import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A+import Text.Blaze.Html5 qualified as H+import Text.Blaze.Html5.Attributes qualified as A  data Route   = Index   | OnlyTime-  deriving (Show, Enum, Bounded)+  deriving stock (Show, Enum, Bounded)  instance Ema UTCTime Route where   encodeRoute _time = \case@@ -39,15 +36,15 @@ main :: IO () main = do   void $-    Ema.runEma (\act m -> Ema.AssetGenerated Ema.Html . render act m) $ \_act model ->+    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 :: Some Ema.CLI.Action -> UTCTime -> Route -> LByteString-render emaAction now r =-  EB.twindLayout emaAction (H.title "Clock" >> H.base ! A.href "/") $+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

@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE TypeApplications #-}  module Ema.Generate where @@ -70,7 +69,8 @@       writeFileLBS nojekyll ""  newtype StaticAssetMissing = StaticAssetMissing FilePath-  deriving (Show, Exception)+  deriving stock (Show)+  deriving anyclass (Exception)  copyDirRecursively ::   ( MonadIO m,

@@ -1,93 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-}---- | Use Tailwind CSS with blaze-html? Try this module for rapid prototyping of--- websites in Ema.-module Ema.Helper.Blaze-  ( -- * Main functions-    layoutWith,-    twindLayout,--    -- * Tailwind official shims-    tailwind2ShimCdn,--    -- * Twind.dev shims-    twindShimOfficial,-    twindShimUnofficial,-  )-where--import Data.Some (Some (Some))-import qualified Ema.CLI-import NeatInterpolation (text)-import qualified Text.Blaze.Html.Renderer.Utf8 as RU-import Text.Blaze.Html5 ((!))-import qualified Text.Blaze.Html5 as H-import qualified Text.Blaze.Html5.Attributes as A---- | A general layout-layoutWith :: H.AttributeValue -> H.AttributeValue -> H.Html -> H.Html -> LByteString-layoutWith lang encoding appHead appBody = RU.renderHtml $ do-  H.docType-  H.html ! A.lang lang $ do-    H.head $ do-      H.meta ! A.charset encoding-      -- This makes the site mobile friendly by default.-      H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"-      appHead-    appBody---- | A simple and off-the-shelf layout using Tailwind CSS-twindLayout :: Some Ema.CLI.Action -> H.Html -> H.Html -> LByteString-twindLayout action h b =-  layoutWith "en" "UTF-8" (shim >> h) $-    -- The "overflow-y-scroll" makes the scrollbar visible always, so as to-    -- avoid janky shifts when switching to routes with suddenly scrollable content.-    H.body ! A.class_ "overflow-y-scroll" $ b-  where-    shim :: H.Html-    shim =-      case action of-        Some (Ema.CLI.Generate _) ->-          twindShimUnofficial-        _ ->-          -- Twind shim doesn't reliably work in dev server mode. Let's just use the-          -- tailwind CDN.-          tailwind2ShimCdn---- | Loads full tailwind CSS from CDN (not good for production)-tailwind2ShimCdn :: H.Html-tailwind2ShimCdn =-  H.link-    ! A.href "https://unpkg.com/tailwindcss@2/dist/tailwind.min.css"-    ! A.rel "stylesheet"-    ! A.type_ "text/css"---- | This shim may not work with hot reload.-twindShimOfficial :: H.Html-twindShimOfficial =-  H.unsafeByteString . encodeUtf8 $-    [text|-    <script type="module" src="https://cdn.skypack.dev/twind/shim"></script>-    |]---- | This shim does work with hot reload, but it spams console with warnings.-twindShimUnofficial :: H.Html-twindShimUnofficial = do-  H.script-    ! A.type_ "text/javascript"-    ! A.src "https://cdn.jsdelivr.net/combine/npm/twind/twind.umd.min.js,npm/twind/observe/observe.umd.min.js"-    $ ""-  H.script ! A.type_ "text/javascript" $ twindShimUnofficialEval-  where-    twindShimUnofficialEval :: H.Html-    twindShimUnofficialEval =-      H.unsafeByteString . encodeUtf8 $-        [text|-        // Be silent to avoid complaining about non-tailwind classes-        // https://github.com/tw-in-js/twind/discussions/180#discussioncomment-678272-        console.log("ema: Twind: setup & observe")-        twind.setup({mode: 'silent'})-        window.emaTwindObs = twindObserve.observe(document.documentElement);-        |]

@@ -1,9 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TypeApplications #-}--module Ema.Helper.FileSystem-  ( module X,-  )-where--import System.UnionMount as X

@@ -1,139 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---- | Helper to deal with Markdown files------ TODO: Publish this eventually to Hackage, along with wiki-link stuff from--- emanote (maybe as separate package).-module Ema.Helper.Markdown-  ( -- Parsing-    -- TODO: Publish to Hackage as commonmark-pandoc-simple?-    parseMarkdownWithFrontMatter,-    parseMarkdown,-    fullMarkdownSpec,-    -- Utilities-    plainify,-  )-where--import qualified Commonmark as CM-import qualified Commonmark.Extensions as CE-import qualified Commonmark.Pandoc as CP-import Control.Monad.Combinators (manyTill)-import Data.Aeson (FromJSON)-import qualified Data.Yaml as Y-import qualified Text.Megaparsec as M-import qualified Text.Megaparsec.Char as M-import qualified Text.Pandoc.Builder as B-import Text.Pandoc.Definition (Pandoc (..))-import qualified Text.Pandoc.Walk as W---- | Parse a Markdown file using commonmark-hs with all extensions enabled-parseMarkdownWithFrontMatter ::-  forall meta m il bl.-  ( FromJSON meta,-    m ~ Either CM.ParseError,-    bl ~ CP.Cm () B.Blocks,-    il ~ CP.Cm () B.Inlines-  ) =>-  CM.SyntaxSpec m il bl ->-  -- | Path to file associated with this Markdown-  FilePath ->-  -- | Markdown text to parse-  Text ->-  Either Text (Maybe meta, Pandoc)-parseMarkdownWithFrontMatter spec fn s = do-  (mMeta, markdown) <- partitionMarkdown fn s-  mMetaVal <- first show $ (Y.decodeEither' . encodeUtf8) `traverse` mMeta-  blocks <- first show $ join $ CM.commonmarkWith @(Either CM.ParseError) spec fn markdown-  let doc = Pandoc mempty $ B.toList . CP.unCm @() @B.Blocks $ blocks-  pure (mMetaVal, doc)--parseMarkdown :: FilePath -> Text -> Either Text Pandoc-parseMarkdown fn s = do-  cmBlocks <- first show $ join $ CM.commonmarkWith @(Either CM.ParseError) fullMarkdownSpec fn s-  let blocks = B.toList . CP.unCm @() @B.Blocks $ cmBlocks-  pure $ Pandoc mempty blocks--type SyntaxSpec' m il bl =-  ( Monad m,-    CM.IsBlock il bl,-    CM.IsInline il,-    Typeable m,-    Typeable il,-    Typeable bl,-    CE.HasEmoji il,-    CE.HasStrikethrough il,-    CE.HasPipeTable il bl,-    CE.HasTaskList il bl,-    CM.ToPlainText il,-    CE.HasFootnote il bl,-    CE.HasMath il,-    CE.HasDefinitionList il bl,-    CE.HasDiv bl,-    CE.HasQuoted il,-    CE.HasSpan il-  )---- | GFM + official commonmark extensions-fullMarkdownSpec ::-  SyntaxSpec' m il bl =>-  CM.SyntaxSpec m il bl-fullMarkdownSpec =-  mconcat-    [ CE.gfmExtensions,-      CE.fancyListSpec,-      CE.footnoteSpec,-      CE.mathSpec,-      CE.smartPunctuationSpec,-      CE.definitionListSpec,-      CE.attributesSpec,-      CE.rawAttributeSpec,-      CE.fencedDivSpec,-      CE.bracketedSpanSpec,-      CE.autolinkSpec,-      CM.defaultSyntaxSpec,-      -- as the commonmark documentation states, pipeTableSpec should be placed after-      -- fancyListSpec and defaultSyntaxSpec to avoid bad results when parsing-      -- non-table lines-      CE.pipeTableSpec-    ]---- | Identify metadata block at the top, and split it from markdown body.------ FIXME: https://github.com/srid/neuron/issues/175-partitionMarkdown :: FilePath -> Text -> Either Text (Maybe Text, Text)-partitionMarkdown =-  parse (M.try splitP <|> fmap (Nothing,) M.takeRest)-  where-    separatorP :: M.Parsec Void Text ()-    separatorP =-      void $ M.string "---" <* M.eol-    splitP :: M.Parsec Void Text (Maybe Text, Text)-    splitP = do-      separatorP-      a <- toText <$> manyTill M.anySingle (M.try $ M.eol *> separatorP)-      b <- M.takeRest-      pure (Just a, b)-    parse :: M.Parsec Void Text a -> String -> Text -> Either Text a-    parse p fn s =-      first (toText . M.errorBundlePretty) $-        M.parse (p <* M.eof) fn s---- | Convert Pandoc AST inlines to raw text.-plainify :: [B.Inline] -> Text-plainify = W.query $ \case-  B.Str x -> x-  B.Code _attr x -> x-  B.Space -> " "-  B.SoftBreak -> " "-  B.LineBreak -> " "-  B.RawInline _fmt s -> s-  B.Math _mathTyp s -> s-  -- Ignore the rest of AST nodes, as they are recursively defined in terms of-  -- `Inline` which `W.query` will traverse again.-  _ -> ""

@@ -1,78 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}---- | Helper to deal with slug trees-module Ema.Helper.PathTree where--import qualified Data.List as List-import qualified Data.List.NonEmpty as NE-import Data.Tree (Tree (Node))-import qualified Data.Tree as Tree---- ---------------------- Data.Tree helpers--- ---------------------treeInsertPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]-treeInsertPath =-  treeInsertPathMaintainingOrder void---- | Insert a node by path into a tree with descendants that are ordered.------ Insertion will guarantee that descendants continue to be ordered as expected.------ The order of descendents is determined by the given order function, which--- takes the path to a node and return that node's order. The intention is to--- lookup the actual order value which exists *outside* of the tree--- datastructure itself.-treeInsertPathMaintainingOrder :: (Eq a, Ord ord) => (NonEmpty a -> ord) -> NonEmpty a -> [Tree a] -> [Tree a]-treeInsertPathMaintainingOrder ordF path t =-  orderedTreeInsertPath ordF (toList path) t []-  where-    orderedTreeInsertPath :: (Eq a, Ord b) => (NonEmpty a -> b) -> [a] -> [Tree a] -> [a] -> [Tree a]-    orderedTreeInsertPath _ [] trees _ =-      trees-    orderedTreeInsertPath pathOrder (top : rest) trees ancestors =-      case treeFindChild top trees of-        Nothing ->-          let newChild = Node top $ orderedTreeInsertPath pathOrder rest [] (top : ancestors)-           in sortChildrenOn pathOrder (trees <> one newChild)-        Just (Node _match grandChildren) ->-          let oneDead = treeDeleteChild top trees-              newChild = Node top $ orderedTreeInsertPath pathOrder rest grandChildren (top : ancestors)-           in sortChildrenOn pathOrder (oneDead <> one newChild)-      where-        treeFindChild x xs =-          List.find (\n -> Tree.rootLabel n == x) xs-        sortChildrenOn f =-          sortOn $ (\s -> f $ NE.reverse $ s :| ancestors) . Tree.rootLabel--treeDeletePath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]-treeDeletePath =-  treeDeletePathWithLastBehavingAs $ \lastInPath ts ->-    List.deleteBy (\x y -> Tree.rootLabel x == Tree.rootLabel y) (Node lastInPath []) ts--treeDeleteLeafPath :: Eq a => NonEmpty a -> [Tree a] -> [Tree a]-treeDeleteLeafPath =-  treeDeletePathWithLastBehavingAs $ \lastInPath ts ->-    case ts of-      [t] -> [t | Tree.rootLabel t /= lastInPath]-      _ -> ts--treeDeletePathWithLastBehavingAs :: forall a. Eq a => (a -> [Tree a] -> [Tree a]) -> NonEmpty a -> [Tree a] -> [Tree a]-treeDeletePathWithLastBehavingAs f slugs =-  go (toList slugs)-  where-    go :: [a] -> [Tree a] -> [Tree a]-    go [] t = t-    go [p] ts =-      f p ts-    go (p : ps) t =-      t <&> \node@(Node x xs) ->-        if x == p-          then Node x $ go ps xs-          else node--treeDeleteChild :: Eq a => a -> [Tree a] -> [Tree a]-treeDeleteChild x =-  List.deleteBy (\p q -> Tree.rootLabel p == Tree.rootLabel q) (Node x [])

@@ -1,6 +1,3 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-}- module Ema.Route   ( routeUrl,     routeUrlWith,@@ -10,16 +7,15 @@  import Data.Aeson (FromJSON (parseJSON), Value) import Data.Aeson.Types (Parser)-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T import Ema.Class (Ema (encodeRoute))-import Ema.Route.Slug (unicodeNormalize)-import qualified Network.URI.Encode as UE+import Network.URI.Slug qualified as Slug  data UrlStrategy   = UrlPretty   | UrlDirect-  deriving (Eq, Show, Ord)+  deriving stock (Eq, Show, Ord)  instance FromJSON UrlStrategy where   parseJSON val =@@ -43,14 +39,15 @@     relUrlFromPath fp =       case T.stripSuffix (urlStrategySuffix urlStrategy) (toText fp) of         Just htmlFp ->-          case nonEmpty (UE.encodeText . unicodeNormalize <$> T.splitOn "/" htmlFp) of+          case nonEmpty (urlSlugFromText <$> T.splitOn "/" htmlFp) of             Nothing ->               ""             Just (removeLastIf "index" -> partsSansIndex) ->               T.intercalate "/" partsSansIndex         Nothing ->-          T.intercalate "/" $ UE.encodeText . unicodeNormalize <$> T.splitOn "/" (toText fp)+          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

@@ -1,38 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}--module Ema.Route.Slug where--import Data.Aeson (FromJSON, ToJSON)-import Data.Data (Data)-import qualified Data.Text as T-import qualified Data.Text.Normalize as UT-import qualified Network.URI.Encode as UE---- | An URL path is made of multiple slugs, separated by '/'-newtype Slug = Slug {unSlug :: Text}-  deriving (Eq, Show, Ord, Data, Generic, ToJSON, FromJSON)---- | Decode an URL component into a `Slug` using `Network.URI.Encode`-decodeSlug :: Text -> Slug-decodeSlug =-  fromString . UE.decode . toString---- | Encode a `Slug` into an URL component using `Network.URI.Encode`-encodeSlug :: Slug -> Text-encodeSlug =-  UE.encodeText . unSlug--instance IsString Slug where-  fromString :: HasCallStack => String -> Slug-  fromString (toText -> s) =-    if "/" `T.isInfixOf` s-      then error ("Slug cannot contain a slash: " <> s)-      else Slug (unicodeNormalize s)---- Normalize varying non-ascii strings (in filepaths / slugs) to one--- representation, so that they can be reliably linked to.-unicodeNormalize :: Text -> Text-unicodeNormalize = UT.normalize UT.NFC . toText

@@ -1,7 +1,4 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeApplications #-}  module Ema.Server where @@ -10,19 +7,19 @@ import Control.Monad.Logger import Data.Default import Data.LVar (LVar)-import qualified Data.LVar as LVar-import qualified Data.Text as T+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 NeatInterpolation (text)-import qualified Network.HTTP.Types as H-import qualified Network.Wai as Wai-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WebSockets as WaiWs-import qualified Network.Wai.Middleware.Static as Static+import Network.HTTP.Types qualified as H+import Network.Wai qualified as Wai+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 qualified Network.WebSockets as WS+import Network.WebSockets qualified as WS import System.FilePath ((</>)) import Text.Printf (printf) import UnliftIO (MonadUnliftIO)@@ -61,9 +58,9 @@           & Warp.setHost (fromString . toString . unHost $ host)   logger <- askLoggerIO -  logInfoN "============================================"-  logInfoN $ "Running live server at http://" <> unHost host <> ":" <> show port-  logInfoN "============================================"+  logInfoN "=============================================="+  logInfoN $ "Ema live server running: http://" <> unHost host <> ":" <> show port+  logInfoN "=============================================="   liftIO $     Warp.runSettings settings $       assetsMiddleware $@@ -302,6 +299,7 @@            function switchRoute(path) {              console.log(`ema: → Switching to $${path}`);+             window.history.pushState({}, "", path);              sendObservePath(path);           } @@ -309,7 +307,6 @@               const origin = e.target.closest("a");               if (origin) {                 if (window.location.host === origin.host && origin.getAttribute("target") != "_blank") {-                  window.history.pushState({}, "", origin.pathname);                   switchRoute(origin.pathname);                   e.preventDefault();                 };@@ -371,6 +368,11 @@           // the addressback, which has the effect of loading it immediately.           window.onpopstate = function(e) {             watchCurrentRoute();+          };++          // API for user invocations +          window.ema = {+            switchRoute: switchRoute           };         };