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 {SlugRoute a -> NonEmpty Slug
unSlugRoute :: NonEmpty Slug}
  deriving stock (SlugRoute a -> SlugRoute a -> Bool
(SlugRoute a -> SlugRoute a -> Bool)
-> (SlugRoute a -> SlugRoute a -> Bool) -> Eq (SlugRoute a)
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, Eq (SlugRoute a)
Eq (SlugRoute a)
-> (SlugRoute a -> SlugRoute a -> Ordering)
-> (SlugRoute a -> SlugRoute a -> Bool)
-> (SlugRoute a -> SlugRoute a -> Bool)
-> (SlugRoute a -> SlugRoute a -> Bool)
-> (SlugRoute a -> SlugRoute a -> Bool)
-> (SlugRoute a -> SlugRoute a -> SlugRoute a)
-> (SlugRoute a -> SlugRoute a -> SlugRoute a)
-> Ord (SlugRoute a)
SlugRoute a -> SlugRoute a -> Bool
SlugRoute a -> SlugRoute a -> Ordering
SlugRoute a -> SlugRoute a -> SlugRoute a
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
$cp1Ord :: forall {a}. Eq (SlugRoute a)
Ord, Int -> SlugRoute a -> ShowS
[SlugRoute a] -> ShowS
SlugRoute a -> String
(Int -> SlugRoute a -> ShowS)
-> (SlugRoute a -> String)
-> ([SlugRoute a] -> ShowS)
-> Show (SlugRoute a)
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 x. SlugRoute a -> Rep (SlugRoute a) x)
-> (forall x. Rep (SlugRoute a) x -> SlugRoute a)
-> Generic (SlugRoute a)
forall x. Rep (SlugRoute a) x -> SlugRoute a
forall x. SlugRoute a -> Rep (SlugRoute a) x
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) =
          Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Slug -> Text
Slug.unSlug (Slug -> Text) -> [Slug] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Slug -> [Slug]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty Slug
slugs
        decode :: String -> Maybe (SlugRoute a)
decode String
fp = do
          Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null String
fp
          NonEmpty Slug
slugs <- [Slug] -> Maybe (NonEmpty Slug)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Slug] -> Maybe (NonEmpty Slug))
-> [Slug] -> Maybe (NonEmpty Slug)
forall a b. (a -> b) -> a -> b
$ String -> Slug
forall a. IsString a => String -> a
fromString (String -> Slug) -> (Text -> String) -> Text -> Slug
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> Slug) -> [Text] -> [Slug]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
T.splitOn Text
"/" (String -> Text
forall a. ToText a => a -> Text
toText String
fp)
          let r :: SlugRoute a
r = NonEmpty Slug -> SlugRoute a
forall a. NonEmpty Slug -> SlugRoute a
SlugRoute NonEmpty Slug
slugs
          Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ SlugRoute a -> Map (SlugRoute a) a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member SlugRoute a
r Map (SlugRoute a) a
RouteModel (SlugRoute a)
m
          SlugRoute a -> Maybe (SlugRoute a)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SlugRoute a
r
     in Prism' String (SlugRoute a) -> Prism_ String (SlugRoute a)
forall s a. Prism' s a -> Prism_ s a
toPrism_ (Prism' String (SlugRoute a) -> Prism_ String (SlugRoute a))
-> Prism' String (SlugRoute a) -> Prism_ String (SlugRoute a)
forall a b. (a -> b) -> a -> b
$ Prism' String String
htmlSuffixPrism Prism' String String
-> Prism' String (SlugRoute a) -> Prism' String (SlugRoute a)
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
% (SlugRoute a -> String)
-> (String -> Maybe (SlugRoute a)) -> Prism' String (SlugRoute a)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' SlugRoute a -> String
forall a. SlugRoute a -> String
encode String -> Maybe (SlugRoute a)
decode
  routeUniverse :: RouteModel (SlugRoute a) -> [SlugRoute a]
routeUniverse = RouteModel (SlugRoute a) -> [SlugRoute a]
forall k a. Map k a -> [k]
Map.keys

mkSlugRoute :: forall a. FilePath -> Maybe (String, SlugRoute a)
mkSlugRoute :: String -> Maybe (String, SlugRoute a)
mkSlugRoute (String -> (String, String)
splitExtension -> (String
relFp, String
ext')) = do
  let slugs :: [Slug]
slugs = String -> Slug
forall a. IsString a => String -> a
fromString (String -> Slug) -> ShowS -> String -> Slug
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (String -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Slug) -> [String] -> [Slug]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
splitPath String
relFp
  (String
ext',) (SlugRoute a -> (String, SlugRoute a))
-> Maybe (SlugRoute a) -> Maybe (String, SlugRoute a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonEmpty Slug -> SlugRoute a) -> [Slug] -> Maybe (SlugRoute a)
forall a b. (NonEmpty a -> b) -> [a] -> Maybe b
viaNonEmpty NonEmpty Slug -> SlugRoute a
forall a. NonEmpty Slug -> SlugRoute a
SlugRoute [Slug]
slugs