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)
newtype SlugRoute (a :: Type) = SlugRoute {forall a. SlugRoute a -> NonEmpty Slug
unSlugRoute :: NonEmpty Slug}
deriving stock (SlugRoute a -> SlugRoute a -> Bool
forall a. SlugRoute a -> SlugRoute a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SlugRoute a -> SlugRoute a -> Bool
$c/= :: forall a. SlugRoute a -> SlugRoute a -> Bool
== :: SlugRoute a -> SlugRoute a -> Bool
$c== :: forall a. SlugRoute a -> SlugRoute a -> Bool
Eq, SlugRoute a -> SlugRoute a -> Bool
SlugRoute a -> SlugRoute a -> Ordering
forall a. Eq (SlugRoute a)
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. SlugRoute a -> SlugRoute a -> Bool
forall a. SlugRoute a -> SlugRoute a -> Ordering
forall a. SlugRoute a -> SlugRoute a -> SlugRoute a
min :: SlugRoute a -> SlugRoute a -> SlugRoute a
$cmin :: forall a. SlugRoute a -> SlugRoute a -> SlugRoute a
max :: SlugRoute a -> SlugRoute a -> SlugRoute a
$cmax :: forall a. SlugRoute a -> SlugRoute a -> SlugRoute a
>= :: SlugRoute a -> SlugRoute a -> Bool
$c>= :: forall a. SlugRoute a -> SlugRoute a -> Bool
> :: SlugRoute a -> SlugRoute a -> Bool
$c> :: forall a. SlugRoute a -> SlugRoute a -> Bool
<= :: SlugRoute a -> SlugRoute a -> Bool
$c<= :: forall a. SlugRoute a -> SlugRoute a -> Bool
< :: SlugRoute a -> SlugRoute a -> Bool
$c< :: forall a. SlugRoute a -> SlugRoute a -> Bool
compare :: SlugRoute a -> SlugRoute a -> Ordering
$ccompare :: forall a. SlugRoute a -> SlugRoute a -> Ordering
Ord, Int -> SlugRoute a -> ShowS
forall a. Int -> SlugRoute a -> ShowS
forall a. [SlugRoute a] -> ShowS
forall a. SlugRoute a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SlugRoute a] -> ShowS
$cshowList :: forall a. [SlugRoute a] -> ShowS
show :: SlugRoute a -> String
$cshow :: forall a. SlugRoute a -> String
showsPrec :: Int -> SlugRoute a -> ShowS
$cshowsPrec :: forall a. Int -> SlugRoute a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (SlugRoute a) x -> SlugRoute a
forall a x. SlugRoute a -> Rep (SlugRoute a) x
$cto :: forall a x. Rep (SlugRoute a) x -> SlugRoute a
$cfrom :: forall a x. SlugRoute a -> Rep (SlugRoute a) x
Generic)
instance IsRoute (SlugRoute a) where
type RouteModel (SlugRoute a) = Map (SlugRoute a) a
routePrism :: RouteModel (SlugRoute a) -> Prism_ String (SlugRoute a)
routePrism RouteModel (SlugRoute a)
m =
let encode :: SlugRoute a -> String
encode (SlugRoute NonEmpty Slug
slugs) =
forall a. ToString a => a -> String
toString forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ Slug -> Text
Slug.unSlug forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty Slug
slugs
decode :: String -> Maybe (SlugRoute a)
decode String
fp = do
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
fp
NonEmpty Slug
slugs <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ 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 (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
T.splitOn Text
"/" (forall a. ToText a => a -> Text
toText String
fp)
let r :: SlugRoute a
r = forall a. NonEmpty Slug -> SlugRoute a
SlugRoute NonEmpty Slug
slugs
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Bool
Map.member SlugRoute a
r RouteModel (SlugRoute a)
m
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SlugRoute a
r
in 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 :: IxList) (js :: IxList) (ks :: IxList) 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 b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall a. SlugRoute a -> String
encode String -> Maybe (SlugRoute a)
decode
routeUniverse :: RouteModel (SlugRoute a) -> [SlugRoute a]
routeUniverse = forall k a. Map k a -> [k]
Map.keys
mkSlugRoute :: forall a. FilePath -> Maybe (String, SlugRoute a)
mkSlugRoute :: forall a. String -> Maybe (String, SlugRoute a)
mkSlugRoute (String -> (String, String)
splitExtension -> (String
relFp, String
ext')) = do
let slugs :: [Slug]
slugs = 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 b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToText a => a -> Text
toText forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
splitPath String
relFp
(String
ext',) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty forall a. NonEmpty Slug -> SlugRoute a
SlugRoute [Slug]
slugs