ema 0.8.2.0 → 0.10.0.0

raw patch · 25 files changed

+15/−1983 lines, 25 filesdep −blaze-htmldep −blaze-markupdep −containersdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: blaze-html, blaze-markup, containers, ema, fsnotify, generic-optics, generics-sop, pandoc, pandoc-types, raw-strings-qq, template-haskell, time, unionmount

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• ema.cabal +2/−78
• src/Ema/Example/Common.hs +0/−50
• src/Ema/Example/Ex00_Hello.hs +0/−21
• src/Ema/Example/Ex01_Basic.hs +0/−44
• src/Ema/Example/Ex02_Clock.hs +0/−89
• src/Ema/Example/Ex03_Store.hs +0/−184
• src/Ema/Example/Ex04_Multi.hs +0/−105
• src/Ema/Example/Ex05_MultiRoute.hs +0/−57
• src/Ema/Route/Generic.hs +0/−164
• src/Ema/Route/Generic/Example.hs +0/−159
• src/Ema/Route/Generic/RGeneric.hs +0/−99
• src/Ema/Route/Generic/SubModel.hs +0/−42
• src/Ema/Route/Generic/SubRoute.hs +0/−113
• src/Ema/Route/Generic/TH.hs +0/−44
• src/Ema/Route/Generic/Verification.hs +0/−57
• src/Ema/Route/Lib/Extra/PandocRoute.hs +0/−197
• src/Ema/Route/Lib/Extra/SlugRoute.hs +0/−40
• src/Ema/Route/Lib/Extra/StaticRoute.hs +0/−111
• src/Ema/Route/Prism/Check.hs +4/−2
• src/Ema/Server.hs +2/−1
• src/GHC/TypeLits/Extra.hs +0/−15
• src/GHC/TypeLits/Extra/Symbol.hs +0/−63
• test/type-errors/Deriving.hs +0/−243
• test/type-errors/Spec.hs +0/−5

@@ -1,5 +1,12 @@ # Revision history for ema +## 0.10.0.0 (2022-11-20)++- Split Ema into multiple packages:+- `ema-extra`: New API+  - Expose `StringRoute` from examples to ema-extra+  - Add `MapRoute` and `PaginatedRoute`+ ## 0.8.2.0 (2022-08-28)  - Bug fixes

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               ema-version:            0.8.2.0+version:            0.10.0.0 license:            AGPL-3.0-only copyright:          2021 Sridhar Ratnakumar maintainer:         srid@srid.ca@@ -26,16 +26,6 @@   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:     True--flag with-extra-  description: Include non-core functionality-  default:     True- common extensions   default-extensions:     NoStarIsType@@ -89,9 +79,8 @@   build-depends:     , aeson     , async-    , base                    >=4.13.0.0 && <=4.17.0.0+    , base                    >=4.13.0.0 && <4.17.0.0.0     , constraints-extras-    , containers     , data-default     , dependent-sum     , dependent-sum-template@@ -99,8 +88,6 @@     , file-embed     , filepath     , filepattern-    , generic-optics-    , generics-sop     , http-types     , lvar     , monad-logger@@ -111,7 +98,6 @@     , optparse-applicative     , relude                  >=1.0     , sop-core-    , template-haskell     , text     , unliftio     , url-slug@@ -121,20 +107,6 @@     , warp     , websockets -  if flag(with-examples)-    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),@@ -154,12 +126,6 @@     Ema.Dynamic     Ema.Generate     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@@ -170,49 +136,7 @@     Ema.Server     Ema.Site -  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.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--  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)

@@ -1,50 +0,0 @@-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-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"---- 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

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

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

@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}--{- | A very simple site with routes, but based on dynamically changing values-- The current time is computed in the server every second, and the resultant- generated HTML is automatically updated on the browser. This is only a demo;- usually we render HTML based on files on disk or something accessible outside- of the browser. More advanced examples will demonstrate that.--}-module Ema.Example.Ex02_Clock where--import Control.Concurrent (threadDelay)-import Control.Monad.Logger (logDebugNS, logInfoNS)-import Data.List ((!!))-import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)-import Ema-import Ema.Example.Common (tailwindLayout)-import Ema.Route.Generic.TH-import Optics.Core (Prism')-import Text.Blaze.Html5 ((!))-import Text.Blaze.Html5 qualified as H-import Text.Blaze.Html5.Attributes qualified as A--type Model = UTCTime--data Route-  = Route_Index-  | Route_OnlyTime-  deriving stock (Show, Eq, Ord, Generic)--deriveGeneric ''Route-deriveIsRoute ''Route [t|'[WithModel Model]|]--instance EmaSite Route where-  type SiteArg Route = Int -- Delay between clock refresh-  siteInput _ timerDelay = do-    t0 <- liftIO getCurrentTime-    pure . Dynamic . (t0,) $ \setModel -> do-      logInfoNS "Ex02" "Starting clock..."-      forever $ do-        liftIO $ threadDelay timerDelay-        t <- liftIO getCurrentTime-        logDebugNS "Ex02" "Updating clock..."-        setModel t-  siteOutput rp m r =-    pure $ Ema.AssetGenerated Ema.Html $ render rp m r--main :: IO ()-main = do-  void $ Ema.runSite @Route delayNormal--delayNormal :: Int-delayNormal = 1000000 -- 1 second--delayFast :: Int-delayFast = 10000--render :: Prism' FilePath Route -> UTCTime -> Route -> LByteString-render rp now r =-  tailwindLayout (H.title "Clock" >> H.base ! A.href "/") $-    H.div ! A.class_ "container mx-auto" $ do-      H.div ! A.class_ "mt-8 p-2 text-center" $ do-        case r of-          Route_Index ->-            "The current date & time is: "-          Route_OnlyTime ->-            "The current time is: "-        H.pre ! A.class_ "text-6xl font-bold mt-2" $ do-          H.span ! A.class_ ("text-" <> randomColor now <> "-500") $ do-            let fmt = case r of-                  Route_Index -> "%Y/%m/%d %H:%M:%S%Q"-                  Route_OnlyTime -> "%H:%M:%S"-            H.toMarkup $ formatTime defaultTimeLocale fmt now-      H.div ! A.class_ "mt-4 text-center" $ do-        case r of-          Route_Index -> do-            routeElem Route_OnlyTime "Hide day?"-          Route_OnlyTime -> do-            routeElem Route_Index "Show day?"-  where-    routeElem r' = H.a ! A.class_ "text-xl text-purple-500 hover:underline" ! routeHref r'-    routeHref r' =-      A.href (fromString . toString $ Ema.routeUrl rp r')-    randomColor t =-      let epochSecs = fromMaybe 0 . readMaybe @Int $ formatTime defaultTimeLocale "%s" t-          colors = ["green", "gray", "purple", "red", "blue", "yellow", "black", "pink"]-       in colors !! mod epochSecs (length colors)

@@ -1,184 +0,0 @@-{-# 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)

@@ -1,105 +0,0 @@-{-# 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

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

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

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

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

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

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

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

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

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

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

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

@@ -85,9 +85,11 @@   let ma' :: Maybe a = preview p s'   -- log $ "Decoding of that encoding: " <> show ma'   unless (s == s') $-    log $ toText s <> " /= " <> toText s' <> " (encoding of '" <> show a <> "')"+    log $+      toText s <> " /= " <> toText s' <> " (encoding of '" <> show a <> "')"   unless (Just a == ma') $-    log $ show (Just a) <> " /= " <> show ma' <> " (decoding of " <> toText s <> ")"+    log $+      show (Just a) <> " /= " <> show ma' <> " (decoding of " <> toText s <> ")"   pure $ (s == s') && (Just a == ma')   where     log = tell . one

@@ -226,7 +226,8 @@ badRouteEncodingMsg :: Show r => BadRouteEncoding r -> Text badRouteEncodingMsg BadRouteEncoding {..} =   toText $-    "A route Prism' is unlawful.\n\nThe URL '" <> toText _bre_urlFilePath+    "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"

@@ -1,15 +0,0 @@-{-# 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)

@@ -1,63 +0,0 @@-{-# 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

@@ -1,243 +0,0 @@-{-# 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-------------------------------------------

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