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 {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