{-# 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
  { Model -> Text
modelStoreName :: Text
  , Model -> Map Slug Product
modelProducts :: Map Slug Product
  , Model -> Map Slug Category
modelCategories :: Map Slug Category
  }
  deriving stock (forall x. Rep Model x -> Model
forall x. Model -> Rep Model x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Model x -> Model
$cfrom :: forall x. Model -> Rep Model x
Generic)
  deriving anyclass (Value -> Parser [Model]
Value -> Parser Model
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Model]
$cparseJSONList :: Value -> Parser [Model]
parseJSON :: Value -> Parser Model
$cparseJSON :: Value -> Parser Model
FromJSON)

newtype Slug = Slug Text
  deriving newtype (Int -> Slug -> ShowS
[Slug] -> ShowS
Slug -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Slug] -> ShowS
$cshowList :: [Slug] -> ShowS
show :: Slug -> String
$cshow :: Slug -> String
showsPrec :: Int -> Slug -> ShowS
$cshowsPrec :: Int -> Slug -> ShowS
Show, Slug -> Slug -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Slug -> Slug -> Bool
$c/= :: Slug -> Slug -> Bool
== :: Slug -> Slug -> Bool
$c== :: Slug -> Slug -> Bool
Eq, Eq Slug
Slug -> Slug -> Bool
Slug -> Slug -> Ordering
Slug -> Slug -> Slug
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Slug -> Slug -> Slug
$cmin :: Slug -> Slug -> Slug
max :: Slug -> Slug -> Slug
$cmax :: Slug -> Slug -> Slug
>= :: Slug -> Slug -> Bool
$c>= :: Slug -> Slug -> Bool
> :: Slug -> Slug -> Bool
$c> :: Slug -> Slug -> Bool
<= :: Slug -> Slug -> Bool
$c<= :: Slug -> Slug -> Bool
< :: Slug -> Slug -> Bool
$c< :: Slug -> Slug -> Bool
compare :: Slug -> Slug -> Ordering
$ccompare :: Slug -> Slug -> Ordering
Ord, String -> Slug
forall a. (String -> a) -> IsString a
fromString :: String -> Slug
$cfromString :: String -> Slug
IsString, Slug -> String
forall a. (a -> String) -> ToString a
toString :: Slug -> String
$ctoString :: Slug -> String
ToString, Value -> Parser [Slug]
Value -> Parser Slug
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Slug]
$cparseJSONList :: Value -> Parser [Slug]
parseJSON :: Value -> Parser Slug
$cparseJSON :: Value -> Parser Slug
FromJSON, FromJSONKeyFunction [Slug]
FromJSONKeyFunction Slug
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [Slug]
$cfromJSONKeyList :: FromJSONKeyFunction [Slug]
fromJSONKey :: FromJSONKeyFunction Slug
$cfromJSONKey :: FromJSONKeyFunction Slug
FromJSONKey)
  deriving stock (forall x. Rep Slug x -> Slug
forall x. Slug -> Rep Slug x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Slug x -> Slug
$cfrom :: forall x. Slug -> Rep Slug x
Generic)

newtype Product = Product {Product -> Text
unProduct :: Text}
  deriving newtype (Int -> Product -> ShowS
[Product] -> ShowS
Product -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Product] -> ShowS
$cshowList :: [Product] -> ShowS
show :: Product -> String
$cshow :: Product -> String
showsPrec :: Int -> Product -> ShowS
$cshowsPrec :: Int -> Product -> ShowS
Show, Product -> Product -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Product -> Product -> Bool
$c/= :: Product -> Product -> Bool
== :: Product -> Product -> Bool
$c== :: Product -> Product -> Bool
Eq, Eq Product
Product -> Product -> Bool
Product -> Product -> Ordering
Product -> Product -> Product
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Product -> Product -> Product
$cmin :: Product -> Product -> Product
max :: Product -> Product -> Product
$cmax :: Product -> Product -> Product
>= :: Product -> Product -> Bool
$c>= :: Product -> Product -> Bool
> :: Product -> Product -> Bool
$c> :: Product -> Product -> Bool
<= :: Product -> Product -> Bool
$c<= :: Product -> Product -> Bool
< :: Product -> Product -> Bool
$c< :: Product -> Product -> Bool
compare :: Product -> Product -> Ordering
$ccompare :: Product -> Product -> Ordering
Ord, String -> Product
forall a. (String -> a) -> IsString a
fromString :: String -> Product
$cfromString :: String -> Product
IsString, Product -> String
forall a. (a -> String) -> ToString a
toString :: Product -> String
$ctoString :: Product -> String
ToString, Value -> Parser [Product]
Value -> Parser Product
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Product]
$cparseJSONList :: Value -> Parser [Product]
parseJSON :: Value -> Parser Product
$cparseJSON :: Value -> Parser Product
FromJSON)

newtype Category = Category {Category -> Text
unCategory :: Text}
  deriving newtype (Int -> Category -> ShowS
[Category] -> ShowS
Category -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Category] -> ShowS
$cshowList :: [Category] -> ShowS
show :: Category -> String
$cshow :: Category -> String
showsPrec :: Int -> Category -> ShowS
$cshowsPrec :: Int -> Category -> ShowS
Show, Category -> Category -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Category -> Category -> Bool
$c/= :: Category -> Category -> Bool
== :: Category -> Category -> Bool
$c== :: Category -> Category -> Bool
Eq, Eq Category
Category -> Category -> Bool
Category -> Category -> Ordering
Category -> Category -> Category
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Category -> Category -> Category
$cmin :: Category -> Category -> Category
max :: Category -> Category -> Category
$cmax :: Category -> Category -> Category
>= :: Category -> Category -> Bool
$c>= :: Category -> Category -> Bool
> :: Category -> Category -> Bool
$c> :: Category -> Category -> Bool
<= :: Category -> Category -> Bool
$c<= :: Category -> Category -> Bool
< :: Category -> Category -> Bool
$c< :: Category -> Category -> Bool
compare :: Category -> Category -> Ordering
$ccompare :: Category -> Category -> Ordering
Ord, String -> Category
forall a. (String -> a) -> IsString a
fromString :: String -> Category
$cfromString :: String -> Category
IsString, Category -> String
forall a. (a -> String) -> ToString a
toString :: Category -> String
$ctoString :: Category -> String
ToString, Value -> Parser [Category]
Value -> Parser Category
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Category]
$cparseJSONList :: Value -> Parser [Category]
parseJSON :: Value -> Parser Category
$cparseJSON :: Value -> Parser Category
FromJSON)

data Route
  = Route_Index
  | Route_About
  | Route_Products ProductRoute
  | Route_Category CategoryRoute
  deriving stock (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show, Route -> Route -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route -> Route -> Bool
$c/= :: Route -> Route -> Bool
== :: Route -> Route -> Bool
$c== :: Route -> Route -> Bool
Eq, Eq Route
Route -> Route -> Bool
Route -> Route -> Ordering
Route -> Route -> Route
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Route -> Route -> Route
$cmin :: Route -> Route -> Route
max :: Route -> Route -> Route
$cmax :: Route -> Route -> Route
>= :: Route -> Route -> Bool
$c>= :: Route -> Route -> Bool
> :: Route -> Route -> Bool
$c> :: Route -> Route -> Bool
<= :: Route -> Route -> Bool
$c<= :: Route -> Route -> Bool
< :: Route -> Route -> Bool
$c< :: Route -> Route -> Bool
compare :: Route -> Route -> Ordering
$ccompare :: Route -> Route -> Ordering
Ord, forall x. Rep Route x -> Route
forall x. Route -> Rep Route x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Route x -> Route
$cfrom :: forall x. Route -> Rep Route x
Generic)

data ProductRoute
  = ProductRoute_Index
  | ProductRoute_Product Slug
  deriving stock (Int -> ProductRoute -> ShowS
[ProductRoute] -> ShowS
ProductRoute -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProductRoute] -> ShowS
$cshowList :: [ProductRoute] -> ShowS
show :: ProductRoute -> String
$cshow :: ProductRoute -> String
showsPrec :: Int -> ProductRoute -> ShowS
$cshowsPrec :: Int -> ProductRoute -> ShowS
Show, ProductRoute -> ProductRoute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProductRoute -> ProductRoute -> Bool
$c/= :: ProductRoute -> ProductRoute -> Bool
== :: ProductRoute -> ProductRoute -> Bool
$c== :: ProductRoute -> ProductRoute -> Bool
Eq, Eq ProductRoute
ProductRoute -> ProductRoute -> Bool
ProductRoute -> ProductRoute -> Ordering
ProductRoute -> ProductRoute -> ProductRoute
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ProductRoute -> ProductRoute -> ProductRoute
$cmin :: ProductRoute -> ProductRoute -> ProductRoute
max :: ProductRoute -> ProductRoute -> ProductRoute
$cmax :: ProductRoute -> ProductRoute -> ProductRoute
>= :: ProductRoute -> ProductRoute -> Bool
$c>= :: ProductRoute -> ProductRoute -> Bool
> :: ProductRoute -> ProductRoute -> Bool
$c> :: ProductRoute -> ProductRoute -> Bool
<= :: ProductRoute -> ProductRoute -> Bool
$c<= :: ProductRoute -> ProductRoute -> Bool
< :: ProductRoute -> ProductRoute -> Bool
$c< :: ProductRoute -> ProductRoute -> Bool
compare :: ProductRoute -> ProductRoute -> Ordering
$ccompare :: ProductRoute -> ProductRoute -> Ordering
Ord, forall x. Rep ProductRoute x -> ProductRoute
forall x. ProductRoute -> Rep ProductRoute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProductRoute x -> ProductRoute
$cfrom :: forall x. ProductRoute -> Rep ProductRoute x
Generic)

data CategoryRoute
  = CategoryRoute_Index
  | CategoryRoute_Category Slug
  deriving stock (Int -> CategoryRoute -> ShowS
[CategoryRoute] -> ShowS
CategoryRoute -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CategoryRoute] -> ShowS
$cshowList :: [CategoryRoute] -> ShowS
show :: CategoryRoute -> String
$cshow :: CategoryRoute -> String
showsPrec :: Int -> CategoryRoute -> ShowS
$cshowsPrec :: Int -> CategoryRoute -> ShowS
Show, CategoryRoute -> CategoryRoute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CategoryRoute -> CategoryRoute -> Bool
$c/= :: CategoryRoute -> CategoryRoute -> Bool
== :: CategoryRoute -> CategoryRoute -> Bool
$c== :: CategoryRoute -> CategoryRoute -> Bool
Eq, Eq CategoryRoute
CategoryRoute -> CategoryRoute -> Bool
CategoryRoute -> CategoryRoute -> Ordering
CategoryRoute -> CategoryRoute -> CategoryRoute
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CategoryRoute -> CategoryRoute -> CategoryRoute
$cmin :: CategoryRoute -> CategoryRoute -> CategoryRoute
max :: CategoryRoute -> CategoryRoute -> CategoryRoute
$cmax :: CategoryRoute -> CategoryRoute -> CategoryRoute
>= :: CategoryRoute -> CategoryRoute -> Bool
$c>= :: CategoryRoute -> CategoryRoute -> Bool
> :: CategoryRoute -> CategoryRoute -> Bool
$c> :: CategoryRoute -> CategoryRoute -> Bool
<= :: CategoryRoute -> CategoryRoute -> Bool
$c<= :: CategoryRoute -> CategoryRoute -> Bool
< :: CategoryRoute -> CategoryRoute -> Bool
$c< :: CategoryRoute -> CategoryRoute -> Bool
compare :: CategoryRoute -> CategoryRoute -> Ordering
$ccompare :: CategoryRoute -> CategoryRoute -> Ordering
Ord, forall x. Rep CategoryRoute x -> CategoryRoute
forall x. CategoryRoute -> Rep CategoryRoute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CategoryRoute x -> CategoryRoute
$cfrom :: forall x. CategoryRoute -> Rep CategoryRoute x
Generic)
  -- We can also do this using TemplateHaskell (see ProductRoute deriving below)
  deriving anyclass (All @[Type] (SListI @Type) (Code CategoryRoute)
Rep CategoryRoute -> CategoryRoute
CategoryRoute -> Rep CategoryRoute
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep CategoryRoute -> CategoryRoute
$cto :: Rep CategoryRoute -> CategoryRoute
from :: CategoryRoute -> Rep CategoryRoute
$cfrom :: CategoryRoute -> Rep CategoryRoute
SOP.Generic, Generic CategoryRoute
forall a.
Generic a
-> (forall (proxy :: Type -> Type).
    proxy a -> DatatypeInfo (Code a))
-> HasDatatypeInfo a
forall (proxy :: Type -> Type).
proxy CategoryRoute -> DatatypeInfo (Code CategoryRoute)
datatypeInfo :: forall (proxy :: Type -> Type).
proxy CategoryRoute -> DatatypeInfo (Code CategoryRoute)
$cdatatypeInfo :: forall (proxy :: Type -> Type).
proxy CategoryRoute -> DatatypeInfo (Code CategoryRoute)
SOP.HasDatatypeInfo)
  deriving
    (forall {k} (r :: k). HasSubRoutes @k r
HasSubRoutes, HasSubRoutes @Type CategoryRoute
RouteModel CategoryRoute
-> NP @Type I (MultiModel (SubRoutes @Type CategoryRoute))
forall r.
HasSubRoutes @Type r
-> (RouteModel r -> NP @Type I (MultiModel (SubRoutes @Type r)))
-> HasSubModels r
subModels :: RouteModel CategoryRoute
-> NP @Type I (MultiModel (SubRoutes @Type CategoryRoute))
$csubModels :: RouteModel CategoryRoute
-> NP @Type I (MultiModel (SubRoutes @Type CategoryRoute))
HasSubModels, RouteModel CategoryRoute -> [CategoryRoute]
RouteModel CategoryRoute -> Prism_ String CategoryRoute
forall r.
(RouteModel r -> Prism_ String r)
-> (RouteModel r -> [r]) -> IsRoute r
routeUniverse :: RouteModel CategoryRoute -> [CategoryRoute]
$crouteUniverse :: RouteModel CategoryRoute -> [CategoryRoute]
routePrism :: RouteModel CategoryRoute -> Prism_ String CategoryRoute
$croutePrism :: RouteModel CategoryRoute -> Prism_ String CategoryRoute
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 {forall a r. StringRoute a r -> r
unStringRoute :: r}
  deriving stock (Int -> StringRoute a r -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a r. Show r => Int -> StringRoute a r -> ShowS
forall a r. Show r => [StringRoute a r] -> ShowS
forall a r. Show r => StringRoute a r -> String
showList :: [StringRoute a r] -> ShowS
$cshowList :: forall a r. Show r => [StringRoute a r] -> ShowS
show :: StringRoute a r -> String
$cshow :: forall a r. Show r => StringRoute a r -> String
showsPrec :: Int -> StringRoute a r -> ShowS
$cshowsPrec :: forall a r. Show r => Int -> StringRoute a r -> ShowS
Show, StringRoute a r -> StringRoute a r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a r. Eq r => StringRoute a r -> StringRoute a r -> Bool
/= :: StringRoute a r -> StringRoute a r -> Bool
$c/= :: forall a r. Eq r => StringRoute a r -> StringRoute a r -> Bool
== :: StringRoute a r -> StringRoute a r -> Bool
$c== :: forall a r. Eq r => StringRoute a r -> StringRoute a r -> Bool
Eq, StringRoute a r -> StringRoute a r -> Bool
StringRoute a r -> StringRoute a r -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {r}. Ord r => Eq (StringRoute a r)
forall a r. Ord r => StringRoute a r -> StringRoute a r -> Bool
forall a r. Ord r => StringRoute a r -> StringRoute a r -> Ordering
forall a r.
Ord r =>
StringRoute a r -> StringRoute a r -> StringRoute a r
min :: StringRoute a r -> StringRoute a r -> StringRoute a r
$cmin :: forall a r.
Ord r =>
StringRoute a r -> StringRoute a r -> StringRoute a r
max :: StringRoute a r -> StringRoute a r -> StringRoute a r
$cmax :: forall a r.
Ord r =>
StringRoute a r -> StringRoute a r -> StringRoute a r
>= :: StringRoute a r -> StringRoute a r -> Bool
$c>= :: forall a r. Ord r => StringRoute a r -> StringRoute a r -> Bool
> :: StringRoute a r -> StringRoute a r -> Bool
$c> :: forall a r. Ord r => StringRoute a r -> StringRoute a r -> Bool
<= :: StringRoute a r -> StringRoute a r -> Bool
$c<= :: forall a r. Ord r => StringRoute a r -> StringRoute a r -> Bool
< :: StringRoute a r -> StringRoute a r -> Bool
$c< :: forall a r. Ord r => StringRoute a r -> StringRoute a r -> Bool
compare :: StringRoute a r -> StringRoute a r -> Ordering
$ccompare :: forall a r. Ord r => StringRoute a r -> StringRoute a r -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a r x. Rep (StringRoute a r) x -> StringRoute a r
forall a r x. StringRoute a r -> Rep (StringRoute a r) x
$cto :: forall a r x. Rep (StringRoute a r) x -> StringRoute a r
$cfrom :: forall a r x. StringRoute a r -> Rep (StringRoute a r) x
Generic)
  deriving anyclass (forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
forall {a} {r}. All @[Type] (SListI @Type) (Code (StringRoute a r))
forall a r. Rep (StringRoute a r) -> StringRoute a r
forall a r. StringRoute a r -> Rep (StringRoute a r)
to :: Rep (StringRoute a r) -> StringRoute a r
$cto :: forall a r. Rep (StringRoute a r) -> StringRoute a r
from :: StringRoute a r -> Rep (StringRoute a r)
$cfrom :: forall a r. StringRoute a r -> Rep (StringRoute a r)
SOP.Generic, forall a.
Generic a
-> (forall (proxy :: Type -> Type).
    proxy a -> DatatypeInfo (Code a))
-> HasDatatypeInfo a
forall a r. Generic (StringRoute a r)
forall a r (proxy :: Type -> Type).
proxy (StringRoute a r) -> DatatypeInfo (Code (StringRoute a r))
datatypeInfo :: forall (proxy :: Type -> Type).
proxy (StringRoute a r) -> DatatypeInfo (Code (StringRoute a r))
$cdatatypeInfo :: forall a r (proxy :: Type -> Type).
proxy (StringRoute a r) -> DatatypeInfo (Code (StringRoute a r))
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 :: RouteModel (StringRoute a r) -> Prism_ String (StringRoute a r)
routePrism RouteModel (StringRoute a r)
as =
    forall s a. Prism' s a -> Prism_ s a
toPrism_ forall a b. (a -> b) -> a -> b
$
      Prism' String String
htmlSuffixPrism
        forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso forall a. IsString a => String -> a
fromString forall a. ToString a => a -> String
toString
        forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall {k} {a}. Ord k => Map k a -> Prism k k k k
mapMemberPrism RouteModel (StringRoute a r)
as
        forall k l m (is :: [Type]) (js :: [Type]) (ks :: [Type]) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall a s. Coercible @Type s a => Iso' s a
coercedTo
    where
      mapMemberPrism :: Map k a -> Prism k k k k
mapMemberPrism Map k a
m =
        forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ \k
r -> do forall (f :: Type -> Type) a. Applicative f => a -> f a
pure k
r forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* (forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ k
r forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map k a
m)
  routeUniverse :: RouteModel (StringRoute a r) -> [StringRoute a r]
routeUniverse RouteModel (StringRoute a r)
as = forall a r. r -> StringRoute a r
StringRoute forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [k]
Map.keys RouteModel (StringRoute a r)
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 :: IO ()
main = forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall r.
(Show r, Eq r, EmaStaticSite r) =>
SiteArg r -> IO [String]
Ema.runSite @Route ()

instance EmaSite Route where
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg Route -> m (Dynamic m (RouteModel Route))
siteInput Some @Type Action
_ () = do
    Model
store0 <- forall (m :: Type -> Type). (MonadIO m, MonadLogger m) => m Model
readStoreFile
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Model
store0,) forall a b. (a -> b) -> a -> b
$ \Model -> m ()
setModel -> do
      Chan Event
ch <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Chan Event)
watchDirForked String
dataDir
      let loop :: m ()
loop = do
            forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log Text
"Waiting for fs event ..."
            Event
evt <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan Chan Event
ch
            forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log forall a b. (a -> b) -> a -> b
$ Text
"Got fs event: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Event
evt
            forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ShowS
takeFileName (Event -> String
FSNotify.eventPath Event
evt) forall a. Eq a => a -> a -> Bool
== String
"store.json") forall a b. (a -> b) -> a -> b
$ do
              Model -> m ()
setModel forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: Type -> Type). (MonadIO m, MonadLogger m) => m Model
readStoreFile
            m ()
loop
      m ()
loop
    where
      dataDir :: String
dataDir = String
"src/Ema/Example/Ex03_Store"
      readStoreFile :: (MonadIO m, MonadLogger m) => m Model
      readStoreFile :: forall (m :: Type -> Type). (MonadIO m, MonadLogger m) => m Model
readStoreFile = do
        forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log Text
"Reading Store file"
        forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' forall a b. (a -> b) -> a -> b
$ String
dataDir String -> ShowS
</> String
"store.json") forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left String
err -> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> StoreFileError
StoreFileMalformed String
err
          Right Model
store -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Model
store
      log :: MonadLogger m => Text -> m ()
      log :: forall (m :: Type -> Type). MonadLogger m => Text -> m ()
log = forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"Ex03_Store"
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' String Route
-> RouteModel Route -> Route -> m (SiteOutput Route)
siteOutput Prism' String Route
rp (Model Text
storeName Map Slug Product
ps Map Slug Category
cats) Route
r =
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Format -> a -> Asset a
Ema.AssetGenerated Format
Ema.Html forall a b. (a -> b) -> a -> b
$
      Html -> Html -> LByteString
tailwindLayout (Html -> Html
H.title (Html
"Store example: " forall a. Semigroup a => a -> a -> a
<> forall a. ToMarkup a => a -> Html
H.toHtml Text
storeName) forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Html
H.base forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/") forall a b. (a -> b) -> a -> b
$
        Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"container mx-auto mt-8 p-2" forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.h1 forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-3xl font-bold" forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml Text
storeName
          case Route
r of
            Route
Route_Index -> do
              Html
"You are on the index page. "
              Route -> Html -> Html
routeElem Route
Route_About Html
"Go to About"
              Html
" or go to "
              Route -> Html -> Html
routeElem (ProductRoute -> Route
Route_Products ProductRoute
ProductRoute_Index) Html
"products"
              Html
" or go to "
              Route -> Html -> Html
routeElem (CategoryRoute -> Route
Route_Category CategoryRoute
CategoryRoute_Index) Html
"categories"
            Route
Route_About -> do
              Route -> Html -> Html
routeElem Route
Route_Index Html
"Go to Index"
              Html
". You are on the about page. "
            Route_Products ProductRoute
pr -> do
              Html -> Html
H.h2 Html
"Products"
              case ProductRoute
pr of
                ProductRoute
ProductRoute_Index -> do
                  Html -> Html
H.p Html
"List of products go here"
                  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Slug Product
ps) forall a b. (a -> b) -> a -> b
$ \(Slug
k, Product Text
p) -> do
                    Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ Route -> Html -> Html
routeElem (ProductRoute -> Route
Route_Products forall a b. (a -> b) -> a -> b
$ Slug -> ProductRoute
ProductRoute_Product Slug
k) forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml Text
p
                  Route -> Html -> Html
routeElem Route
Route_Index Html
"Back to index"
                ProductRoute_Product Slug
name -> do
                  Html -> Html
H.h3 forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"p-2 border-2" forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Slug
name Map Slug Product
ps
                  Route -> Html -> Html
routeElem (ProductRoute -> Route
Route_Products ProductRoute
ProductRoute_Index) Html
"Back to products"
            Route_Category CategoryRoute
cr -> do
              Html -> Html
H.h2 Html
"Categories"
              case CategoryRoute
cr of
                CategoryRoute
CategoryRoute_Index -> do
                  Html -> Html
H.p Html
"List of categories go here"
                  forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Slug Category
cats) forall a b. (a -> b) -> a -> b
$ \(Slug
k, Category Text
c) -> do
                    Html -> Html
H.li forall a b. (a -> b) -> a -> b
$ Route -> Html -> Html
routeElem (CategoryRoute -> Route
Route_Category forall a b. (a -> b) -> a -> b
$ Slug -> CategoryRoute
CategoryRoute_Category Slug
k) forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
H.toHtml Text
c
                  Route -> Html -> Html
routeElem Route
Route_Index Html
"Back to index"
                CategoryRoute_Category Slug
name -> do
                  Html -> Html
H.h3 forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"p-2 border-2" forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Slug
name Map Slug Category
cats
                  Route -> Html -> Html
routeElem (CategoryRoute -> Route
Route_Category CategoryRoute
CategoryRoute_Index) Html
"Back to categories"
    where
      routeElem :: Route -> Html -> Html
routeElem Route
r' Html
w = do
        Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-red-500 hover:underline" forall h. Attributable h => h -> Attribute -> h
! Route -> Attribute
routeHref Route
r' forall a b. (a -> b) -> a -> b
$ Html
w
      routeHref :: Route -> Attribute
routeHref Route
r' =
        AttributeValue -> Attribute
A.href (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString forall a b. (a -> b) -> a -> b
$ forall r. HasCallStack => Prism' String r -> r -> Text
Ema.routeUrl Prism' String Route
rp Route
r')

newtype StoreFileError = StoreFileMalformed String
  deriving stock (Int -> StoreFileError -> ShowS
[StoreFileError] -> ShowS
StoreFileError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StoreFileError] -> ShowS
$cshowList :: [StoreFileError] -> ShowS
show :: StoreFileError -> String
$cshow :: StoreFileError -> String
showsPrec :: Int -> StoreFileError -> ShowS
$cshowsPrec :: Int -> StoreFileError -> ShowS
Show, StoreFileError -> StoreFileError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StoreFileError -> StoreFileError -> Bool
$c/= :: StoreFileError -> StoreFileError -> Bool
== :: StoreFileError -> StoreFileError -> Bool
$c== :: StoreFileError -> StoreFileError -> Bool
Eq)
  deriving anyclass (Show StoreFileError
Typeable @Type StoreFileError
SomeException -> Maybe StoreFileError
StoreFileError -> String
StoreFileError -> SomeException
forall e.
Typeable @Type e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: StoreFileError -> String
$cdisplayException :: StoreFileError -> String
fromException :: SomeException -> Maybe StoreFileError
$cfromException :: SomeException -> Maybe StoreFileError
toException :: StoreFileError -> SomeException
$ctoException :: StoreFileError -> SomeException
Exception)