From c0f1c8080aaead7c106130dde12c0cdf64f967c0 Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Sat, 12 Mar 2022 16:02:25 -0500 Subject: [PATCH] add some encoders, and a new example WIP --- .hlint.yaml | 1 + ema.cabal | 3 +- src/Ema/Example/Ex01_Basic.hs | 40 +++++++++++++++++++ src/Ema/Example/Ex02_Basic.hs | 46 --------------------- src/Ema/Example/Ex02_Bookshelf.hs | 66 +++++++++++++++++++++++++++++++ src/Ema/Example/Ex04_Multi.hs | 17 ++++---- src/Ema/Model.hs | 13 +----- src/Ema/Route/Class.hs | 26 ++++++++++-- src/Ema/Route/Encoder.hs | 12 +++--- src/Ema/Server.hs | 1 - 10 files changed, 150 insertions(+), 75 deletions(-) create mode 100644 .hlint.yaml create mode 100644 src/Ema/Example/Ex01_Basic.hs delete mode 100644 src/Ema/Example/Ex02_Basic.hs create mode 100644 src/Ema/Example/Ex02_Bookshelf.hs diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..a1a0192 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1 @@ +- ignore: {name: Use camelCase } \ No newline at end of file diff --git a/ema.cabal b/ema.cabal index 503d91d..c6e012c 100644 --- a/ema.cabal +++ b/ema.cabal @@ -138,7 +138,8 @@ library if flag(with-examples) other-modules: Ema.Example.Common - Ema.Example.Ex02_Basic + Ema.Example.Ex01_Basic + Ema.Example.Ex02_Bookshelf Ema.Example.Ex03_Clock Ema.Example.Ex04_Multi diff --git a/src/Ema/Example/Ex01_Basic.hs b/src/Ema/Example/Ex01_Basic.hs new file mode 100644 index 0000000..d3b8ab0 --- /dev/null +++ b/src/Ema/Example/Ex01_Basic.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# 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 Generics.SOP qualified as SOP +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, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo, HasModel, IsRoute) + +main :: IO () +main = void $ Ema.runSite @Route () + +instance RenderAsset Route where + renderAsset enc () r = + 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 = + H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w + routeHref r' = + A.href (fromString . toString $ Ema.routeUrl enc () r') diff --git a/src/Ema/Example/Ex02_Basic.hs b/src/Ema/Example/Ex02_Basic.hs deleted file mode 100644 index 0af40ed..0000000 --- a/src/Ema/Example/Ex02_Basic.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use camelCase" #-} - --- | A very simple site with two routes, and HTML rendered using Blaze DSL -module Ema.Example.Ex02_Basic where - -import Ema -import Ema.Example.Common (tailwindLayout) -import Ema.Route.Class (IsRoute) -import GHC.Generics qualified as GHC -import Generics.SOP (Generic, HasDatatypeInfo) -import Text.Blaze.Html5 ((!)) -import Text.Blaze.Html5 qualified as H -import Text.Blaze.Html5.Attributes qualified as A -import Prelude hiding (Generic) - -data Route - = Route_Index - | Route_About - deriving stock (Show, Eq, GHC.Generic) - deriving anyclass (Generic, HasDatatypeInfo, IsRoute, HasModel) - -main :: IO () -main = void $ Ema.runSite @Route () - -instance RenderAsset Route where - renderAsset enc () r = - Ema.AssetGenerated Ema.Html $ - 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 - 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 = - H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w - routeHref r' = - A.href (fromString . toString $ Ema.routeUrl enc () r') diff --git a/src/Ema/Example/Ex02_Bookshelf.hs b/src/Ema/Example/Ex02_Bookshelf.hs new file mode 100644 index 0000000..75a1c6b --- /dev/null +++ b/src/Ema/Example/Ex02_Bookshelf.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | TODO: rewrite this to load books.json and display that, with individual page for books too. +module Ema.Example.Ex02_Bookshelf where + +import Ema +import Ema.Example.Common (tailwindLayout) +import Generics.SOP qualified as SOP +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 + | Route_Products ProductRoute + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo, HasModel, IsRoute) + +-- TODO: Use DerivingVia to specify options, to disable extra /product/ in URL. +data ProductRoute + = ProductRoute_Index + | ProductRoute_Product ProductName + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo, IsRoute) + +-- TODO: Demonstrate all_ using a model (that loads from .json?) +newtype ProductName = ProductName Text + deriving stock (Show, Eq) + deriving newtype (IsString, ToString, IsRoute) + +main :: IO () +main = void $ Ema.runSite @Route () + +instance RenderAsset Route where + renderAsset enc () r = + 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" $ "TODO: Bookshelf" + 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" + 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" + H.li $ routeElem (Route_Products $ ProductRoute_Product "egg") "Eggs" + H.li $ routeElem (Route_Products $ ProductRoute_Product "sausage") "Sausages" + routeElem Route_Index "Back to index" + ProductRoute_Product name -> do + H.h3 ! A.class_ "p-2 border-2" $ fromString . toString $ name + routeElem (Route_Products ProductRoute_Index) "Back to products" + where + routeElem r' w = + H.a ! A.class_ "text-red-500 hover:underline" ! routeHref r' $ w + routeHref r' = + A.href (fromString . toString $ Ema.routeUrl enc () r') diff --git a/src/Ema/Example/Ex04_Multi.hs b/src/Ema/Example/Ex04_Multi.hs index 39a2eff..37dd01b 100644 --- a/src/Ema/Example/Ex04_Multi.hs +++ b/src/Ema/Example/Ex04_Multi.hs @@ -8,7 +8,8 @@ module Ema.Example.Ex04_Multi where import Data.Generics.Sum.Any (AsAny (_As)) import Ema import Ema.Example.Common (tailwindLayout) -import Ema.Example.Ex02_Basic qualified as Ex02 +import Ema.Example.Ex01_Basic qualified as Ex01 +import Ema.Example.Ex02_Bookshelf qualified as Ex02 import Ema.Example.Ex03_Clock qualified as Ex03 import GHC.Generics qualified as GHC import Generics.SOP (Generic, HasDatatypeInfo, I (..), NP (..)) @@ -19,7 +20,8 @@ import Prelude hiding (Generic) data R = R_Index - | R_Basic Ex02.Route + | R_Basic Ex01.Route + | R_Bookshelf Ex02.Route | R_Clock Ex03.Route deriving stock (Show, Eq, GHC.Generic) deriving anyclass (Generic, HasDatatypeInfo, IsRoute) @@ -41,11 +43,11 @@ instance RenderAsset R where R_Index -> Ema.AssetGenerated Ema.Html $ renderIndex m R_Basic r -> - let enc' = innerRouteEncoder (_As @"R_Basic") enc - in renderAsset enc' (innerModel m) r + renderAsset (innerRouteEncoder (_As @"R_Basic") enc) (innerModel m) r + R_Bookshelf r -> + renderAsset (innerRouteEncoder (_As @"R_Bookshelf") enc) (innerModel m) r R_Clock r -> - let enc' = innerRouteEncoder (_As @"R_Clock") enc - in renderAsset enc' (innerModel m) r + renderAsset (innerRouteEncoder (_As @"R_Clock") enc) (innerModel m) r renderIndex :: M -> LByteString renderIndex (I clockTime :* Nil) = @@ -53,7 +55,8 @@ renderIndex (I clockTime :* Nil) = H.div ! A.class_ "container mx-auto text-center mt-8 p-2" $ do H.p "You can compose Ema sites. Here are two 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 "basic" "Ex02_Basic" + H.li $ routeElem "basic" "Ex01_Basic" + H.li $ routeElem "bookshelf" "Ex02_Bookshelf" H.li $ routeElem "clock" "Ex03_Clock" H.p $ do "The current time is: " diff --git a/src/Ema/Model.hs b/src/Ema/Model.hs index deafd45..12f7168 100644 --- a/src/Ema/Model.hs +++ b/src/Ema/Model.hs @@ -3,14 +3,13 @@ module Ema.Model ( HasModel (..), - unitModel, ) where import Control.Monad.Logger (MonadLoggerIO) import Data.Some (Some) import Ema.CLI qualified as CLI -import Ema.Dynamic (Dynamic (Dynamic)) +import Ema.Dynamic (Dynamic) import Ema.Route.Class (IsRoute (RouteModel)) import Ema.Route.Encoder (RouteEncoder) import UnliftIO (MonadUnliftIO) @@ -36,12 +35,4 @@ class IsRoute r => HasModel r where RouteEncoder (RouteModel r) r -> ModelInput r -> m (Dynamic m (RouteModel r)) - runModel _ _ _ = pure unitModel - -unitModel :: Monad m => Dynamic m () -unitModel = - Dynamic - ( (), - \_set -> do - pure () - ) + runModel _ _ _ = pure $ pure () diff --git a/src/Ema/Route/Class.hs b/src/Ema/Route/Class.hs index 4530bbe..389d31d 100644 --- a/src/Ema/Route/Class.hs +++ b/src/Ema/Route/Class.hs @@ -7,6 +7,8 @@ module Ema.Route.Class ( IsRoute (RouteModel, mkRouteEncoder), gMkRouteEncoder, ConstModelRoute (..), + ShowReadable (ShowReadable), + Stringable (Stringable), -- * Sub routes innerRouteEncoder, @@ -60,6 +62,24 @@ instance mkRouteEncoder = gMkRouteEncoder @r & mapRouteEncoder (iso id Just) (prism' unConstModelRoute (Just . ConstModelRoute)) (const ()) +newtype ShowReadable a = ShowReadable a + deriving newtype (Show, Read) + +newtype Stringable a = Stringable a + deriving newtype (ToString, IsString) + +instance (Show a, Read a) => IsRoute (ShowReadable a) where + type RouteModel (ShowReadable a) = () + mkRouteEncoder = showReadRouteEncoder + +instance (IsString a, ToString a) => IsRoute (Stringable a) where + type RouteModel (Stringable a) = () + mkRouteEncoder = stringRouteEncoder + +deriving via (Stringable Text) instance IsRoute Text + +deriving via (Stringable String) instance IsRoute String + instance IsRoute () where type RouteModel () = () mkRouteEncoder = singletonRouteEncoder @@ -83,6 +103,8 @@ class HasModel (xs :: [Type]) (x :: Type) where -- | Fill in the outter model containing the given inner model. outerModel :: x -> NP I xs +-- Could probably replace this lens-sop: +-- with https://hackage.haskell.org/package/lens-sop-0.2.0.3/docs/Generics-SOP-Lens.html#v:np instance {-# OVERLAPPING #-} HasModel '[] () where innerModel _ = () outerModel () = Nil @@ -103,14 +125,12 @@ instance {-# OVERLAPPABLE #-} HasModel xs x => HasModel (x' ': xs) x where innerModel (_ :* xs) = innerModel xs outerModel x = I undefined :* outerModel x --- TODO: avoid Iso using https://hackage.haskell.org/package/generic-lens - -- | Extract the inner RouteEncoder. +-- TODO: avoid having to specify Prism innerRouteEncoder :: forall m o i (ms :: [Type]). HasModel ms m => Prism' o i -> - -- Iso o o (Maybe i) i -> RouteEncoder (NP I ms) o -> RouteEncoder m i innerRouteEncoder prism = diff --git a/src/Ema/Route/Encoder.hs b/src/Ema/Route/Encoder.hs index ed88bfb..48d4c66 100644 --- a/src/Ema/Route/Encoder.hs +++ b/src/Ema/Route/Encoder.hs @@ -11,6 +11,7 @@ module Ema.Route.Encoder singletonRouteEncoderFrom, isoRouteEncoder, showReadRouteEncoder, + stringRouteEncoder, mapRouteEncoder, leftRouteEncoder, rightRouteEncoder, @@ -177,12 +178,11 @@ isoRouteEncoder iso = showReadRouteEncoder :: (Show r, Read r) => RouteEncoder () r showReadRouteEncoder = - unsafeMkRouteEncoder (const enc) (const dec) (const []) - where - enc r = show r <> ".html" - dec fp = do - x' <- fmap toString $ T.stripSuffix ".html" $ toText fp - readMaybe x' + isoRouteEncoder $ iso ((<> ".html") . show) (readMaybe <=< fmap toString . T.stripSuffix ".html" . toText) + +stringRouteEncoder :: (IsString a, ToString a) => RouteEncoder () a +stringRouteEncoder = + isoRouteEncoder $ iso ((<> ".html") . toString) (fmap (fromString . toString) . T.stripSuffix ".html" . toText) -- | Route encoder for single route encoding to 'index.html' singletonRouteEncoder :: RouteEncoder a () diff --git a/src/Ema/Server.hs b/src/Ema/Server.hs index 486fbc3..63139bc 100644 --- a/src/Ema/Server.hs +++ b/src/Ema/Server.hs @@ -13,7 +13,6 @@ import Data.LVar qualified as LVar import Data.Text qualified as T import Ema.Asset import Ema.CLI -import Ema.Model import Ema.Route.Class import Ema.Route.Encoder ( checkRouteEncoderForSingleRoute,