RouteEncoder: add Contravariant instance

ema.cabal

@@ -36,6 +36,7 @@ library
     , base                    >=4.13.0.0 && <=4.17.0.0
     , constraints-extras
     , containers
+    , contravariant
     , data-default
     , dependent-sum
     , dependent-sum-template

src/Ema.hs

@@ -6,7 +6,7 @@ where
 import Ema.App as X
 import Ema.Asset as X
 import Ema.Route as X
-  ( RouteEncoder,
+  ( RouteEncoder (RouteEncoder),
     UrlStrategy,
     defaultEnum,
     routeUrl,

src/Ema/Example/Ex02_Basic.hs

@@ -14,9 +14,9 @@ data Route
 
 newtype Model = Model {unModel :: Text}
 
-routeEncoder :: RouteEncoder a Route
+routeEncoder :: RouteEncoder Route a
 routeEncoder =
-  (enc, dec, all_)
+  RouteEncoder (enc, dec, all_)
   where
     enc _model =
       \case
@@ -42,7 +42,7 @@ main :: IO ()
 main = do
   void $ Ema.runSite site
 
-render :: RouteEncoder Model Route -> Model -> Route -> LByteString
+render :: RouteEncoder Route Model -> Model -> Route -> LByteString
 render enc model r =
   tailwindLayout (H.title "Basic site" >> H.base ! A.href "/") $
     H.div ! A.class_ "container mx-auto" $ do

src/Ema/Example/Ex03_Clock.hs

@@ -23,9 +23,9 @@ data Route
   | OnlyTime
   deriving stock (Show, Eq, Enum, Bounded)
 
-routeEncoder :: RouteEncoder a Route
+routeEncoder :: RouteEncoder Route a
 routeEncoder =
-  (enc, dec, all_)
+  RouteEncoder (enc, dec, all_)
   where
     enc _time = \case
       Index -> "index.html"
@@ -57,7 +57,7 @@ main :: IO ()
 main = do
   void $ Ema.runSite site
 
-render :: RouteEncoder UTCTime Route -> UTCTime -> Route -> LByteString
+render :: RouteEncoder Route UTCTime -> UTCTime -> Route -> LByteString
 render enc now r =
   tailwindLayout (H.title "Clock" >> H.base ! A.href "/") $
     H.div ! A.class_ "container mx-auto" $ do

src/Ema/Generate.hs

@@ -53,7 +53,7 @@ generate ::
     Show r
   ) =>
   FilePath ->
-  RouteEncoder a r ->
+  RouteEncoder r a ->
   a ->
   (a -> r -> Asset LByteString) ->
   -- | List of generated files.

src/Ema/Route.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE InstanceSigs #-}
+
 module Ema.Route
   ( -- * Create URL from route
     routeUrl,
@@ -5,7 +7,7 @@ module Ema.Route
     UrlStrategy (..),
 
     -- * Route encoder
-    RouteEncoder,
+    RouteEncoder (RouteEncoder),
     encodeRoute,
     decodeRoute,
     allRoutes,
@@ -19,64 +21,78 @@ where
 
 import Data.Aeson (FromJSON (parseJSON), Value)
 import Data.Aeson.Types (Parser)
+import Data.Functor.Contravariant
 import Data.List.NonEmpty qualified as NE
 import Data.Text qualified as T
 import Network.URI.Slug qualified as Slug
 
 -- | An Iso that is not necessarily surjective; as well as takes an (unchanging)
 -- context value.
-type PartialIsoEnumerableWithCtx ctx s a = (ctx -> a -> s, ctx -> s -> Maybe a, ctx -> [a])
+type PartialIsoEnumerableWithCtx s ctx a = (ctx -> a -> s, ctx -> s -> Maybe a, ctx -> [a])
 
-partialIsoIsLawfulFor :: (Eq a, Eq s) => PartialIsoEnumerableWithCtx ctx s a -> ctx -> a -> s -> Bool
+partialIsoIsLawfulFor :: (Eq a, Eq s) => PartialIsoEnumerableWithCtx s ctx a -> ctx -> a -> s -> Bool
 partialIsoIsLawfulFor (to, from, _) ctx a s =
   (s == to ctx a)
     && (Just a == from ctx s)
 
-type RouteEncoder model route = PartialIsoEnumerableWithCtx model FilePath route
+data RouteEncoder r a = RouteEncoder {unRouteEncoder :: PartialIsoEnumerableWithCtx FilePath a r}
 
-encodeRoute :: RouteEncoder model r -> model -> r -> FilePath
-encodeRoute (f, _, _) = f
+instance Contravariant (RouteEncoder r) where
+  contramap :: forall a b. (a -> b) -> RouteEncoder r b -> RouteEncoder r a
+  contramap f enc =
+    RouteEncoder
+      ( \m r ->
+          encodeRoute enc (f m) r,
+        \m fp ->
+          decodeRoute enc (f m) fp,
+        \m ->
+          allRoutes enc (f m)
+      )
 
-decodeRoute :: RouteEncoder model r -> model -> FilePath -> Maybe r
-decodeRoute (_, f, _) = f
+encodeRoute :: RouteEncoder r model -> model -> r -> FilePath
+encodeRoute (RouteEncoder (f, _, _)) = f
 
-allRoutes :: RouteEncoder model r -> model -> [r]
-allRoutes (_, _, f) = f
+decodeRoute :: RouteEncoder r model -> model -> FilePath -> Maybe r
+decodeRoute (RouteEncoder (_, f, _)) = f
+
+allRoutes :: RouteEncoder r model -> model -> [r]
+allRoutes (RouteEncoder (_, _, f)) = f
 
 -- | Returns a new route encoder that supports either of the input routes.
-mergeRouteEncoder :: RouteEncoder a r1 -> RouteEncoder b r2 -> RouteEncoder (a, b) (Either r1 r2)
+mergeRouteEncoder :: RouteEncoder r1 a -> RouteEncoder r2 b -> RouteEncoder (Either r1 r2) (a, b)
 mergeRouteEncoder enc1 enc2 =
-  ( \m ->
-      either
-        (encodeRoute enc1 (fst m))
-        (encodeRoute enc2 (snd m)),
-    \m fp ->
-      asum
-        [ Left <$> decodeRoute enc1 (fst m) fp,
-          Right <$> decodeRoute enc2 (snd m) fp
-        ],
-    \m ->
-      mconcat
-        [ Left <$> allRoutes enc1 (fst m),
-          Right <$> allRoutes enc2 (snd m)
-        ]
-  )
+  RouteEncoder
+    ( \m ->
+        either
+          (encodeRoute enc1 (fst m))
+          (encodeRoute enc2 (snd m)),
+      \m fp ->
+        asum
+          [ Left <$> decodeRoute enc1 (fst m) fp,
+            Right <$> decodeRoute enc2 (snd m) fp
+          ],
+      \m ->
+        mconcat
+          [ Left <$> allRoutes enc1 (fst m),
+            Right <$> allRoutes enc2 (snd m)
+          ]
+    )
 
 -- TODO: Determine this generically somehow
 -- See https://github.com/srid/ema/issues/76
 defaultEnum :: (Bounded r, Enum r) => [r]
 defaultEnum = [minBound .. maxBound]
 
-checkRouteEncoderForSingleRoute :: Eq route => RouteEncoder model route -> model -> route -> FilePath -> Bool
-checkRouteEncoderForSingleRoute = partialIsoIsLawfulFor
+checkRouteEncoderForSingleRoute :: Eq route => RouteEncoder route model -> model -> route -> FilePath -> Bool
+checkRouteEncoderForSingleRoute = partialIsoIsLawfulFor . unRouteEncoder
 
 -- | Return the relative URL of the given route
 --
 -- As the returned URL is relative, you will have to either make it absolute (by
 -- prepending with `/`) or set the `<base>` URL in your HTML head element.
-routeUrlWith :: UrlStrategy -> RouteEncoder a r -> a -> r -> Text
-routeUrlWith urlStrategy (enc, _, _) model =
-  relUrlFromPath . enc model
+routeUrlWith :: UrlStrategy -> RouteEncoder r a -> a -> r -> Text
+routeUrlWith urlStrategy enc model =
+  relUrlFromPath . encodeRoute enc model
   where
     relUrlFromPath :: FilePath -> Text
     relUrlFromPath fp =
@@ -100,7 +116,7 @@ routeUrlWith urlStrategy (enc, _, _) model =
           UrlPretty -> ".html"
           UrlDirect -> ""
 
-routeUrl :: RouteEncoder a r -> a -> r -> Text
+routeUrl :: RouteEncoder r a -> a -> r -> Text
 routeUrl =
   routeUrlWith UrlPretty
 

src/Ema/Site.hs

@@ -25,10 +25,7 @@ import Data.Text qualified as T
 import Ema.Asset (Asset (AssetGenerated), Format (Html))
 import Ema.CLI qualified as CLI
 import Ema.Route
-  ( RouteEncoder,
-    allRoutes,
-    decodeRoute,
-    encodeRoute,
+  ( RouteEncoder (RouteEncoder),
     mergeRouteEncoder,
   )
 import System.FilePath ((</>))
@@ -41,7 +38,7 @@ data Site a r = Site
   { siteName :: Text,
     siteRender ::
       Some CLI.Action ->
-      RouteEncoder a r ->
+      RouteEncoder r a ->
       a ->
       r ->
       Asset LByteString,
@@ -57,7 +54,7 @@ data Site a r = Site
       (a -> (LVar a -> m ()) -> m b) ->
       m b,
     siteRouteEncoder ::
-      RouteEncoder a r
+      RouteEncoder r a
   }
 
 -- | Create a site with a single 'index.html' route, whose contents is specified
@@ -73,10 +70,11 @@ singlePageSite name render =
       siteModelPatcher =
         constModal (),
       siteRouteEncoder =
-        ( \() () -> "index.html",
-          \() fp -> guard (fp == "index.html"),
-          \() -> [()]
-        )
+        RouteEncoder
+          ( \() () -> "index.html",
+            \() fp -> guard (fp == "index.html"),
+            \() -> [()]
+          )
     }
 
 constModal ::
@@ -151,22 +149,25 @@ mountUnder prefix Site {..} =
     siteRender' cliAct rEnc model (PrefixedRoute _ r) =
       siteRender cliAct (conv rEnc) model r
     conv ::
-      RouteEncoder a (PrefixedRoute r) ->
-      RouteEncoder a r
-    conv (to, from, enum) =
-      ( \m r -> to m (PrefixedRoute prefix r),
-        \m fp -> _prefixedRouteRoute <$> from m fp,
-        \m -> _prefixedRouteRoute <$> enum m
-      )
-    routeEncoder :: RouteEncoder a (PrefixedRoute r)
+      RouteEncoder (PrefixedRoute r) a ->
+      RouteEncoder r a
+    conv (RouteEncoder (to, from, enum)) =
+      RouteEncoder
+        ( \m r -> to m (PrefixedRoute prefix r),
+          \m fp -> _prefixedRouteRoute <$> from m fp,
+          \m -> _prefixedRouteRoute <$> enum m
+        )
+    routeEncoder :: RouteEncoder (PrefixedRoute r) a
     routeEncoder =
-      let (to, from, all_) = siteRouteEncoder
-       in ( \m r -> prefix </> to m (_prefixedRouteRoute r),
-            \m fp -> do
-              fp' <- fmap toString $ T.stripPrefix (toText $ prefix <> "/") $ toText fp
-              fmap (PrefixedRoute prefix) . from m $ fp',
-            fmap (PrefixedRoute prefix) . all_
-          )
+      -- TODO: BiFunctor? and above?
+      let RouteEncoder (to, from, all_) = siteRouteEncoder
+       in RouteEncoder
+            ( \m r -> prefix </> to m (_prefixedRouteRoute r),
+              \m fp -> do
+                fp' <- fmap toString $ T.stripPrefix (toText $ prefix <> "/") $ toText fp
+                fmap (PrefixedRoute prefix) . from m $ fp',
+              fmap (PrefixedRoute prefix) . all_
+            )
 
 -- | A route that is prefixed at some URL prefix
 data PrefixedRoute r = PrefixedRoute