{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}

module Ema.Route.Slug where

import Data.Aeson (FromJSON, ToJSON)
import Data.Data (Data)
import qualified Data.Text as T
import qualified Data.Text.Normalize as UT
import qualified Network.URI.Encode as UE

-- | An URL path is made of multiple slugs, separated by '/'
newtype Slug = Slug {Slug -> Text
unSlug :: Text}
  deriving (Slug -> Slug -> Bool
(Slug -> Slug -> Bool) -> (Slug -> Slug -> Bool) -> Eq Slug
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, Int -> Slug -> ShowS
[Slug] -> ShowS
Slug -> String
(Int -> Slug -> ShowS)
-> (Slug -> String) -> ([Slug] -> ShowS) -> Show Slug
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, Eq Slug
Eq Slug
-> (Slug -> Slug -> Ordering)
-> (Slug -> Slug -> Bool)
-> (Slug -> Slug -> Bool)
-> (Slug -> Slug -> Bool)
-> (Slug -> Slug -> Bool)
-> (Slug -> Slug -> Slug)
-> (Slug -> Slug -> Slug)
-> Ord 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
$cp1Ord :: Eq Slug
Ord, Typeable Slug
DataType
Constr
Typeable Slug
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Slug -> c Slug)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Slug)
-> (Slug -> Constr)
-> (Slug -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Slug))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Slug))
-> ((forall b. Data b => b -> b) -> Slug -> Slug)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r)
-> (forall u. (forall d. Data d => d -> u) -> Slug -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Slug -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Slug -> m Slug)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Slug -> m Slug)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Slug -> m Slug)
-> Data Slug
Slug -> DataType
Slug -> Constr
(forall b. Data b => b -> b) -> Slug -> Slug
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Slug -> c Slug
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Slug
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Slug -> u
forall u. (forall d. Data d => d -> u) -> Slug -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Slug -> m Slug
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Slug -> m Slug
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Slug
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Slug -> c Slug
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Slug)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Slug)
$cSlug :: Constr
$tSlug :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Slug -> m Slug
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Slug -> m Slug
gmapMp :: (forall d. Data d => d -> m d) -> Slug -> m Slug
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Slug -> m Slug
gmapM :: (forall d. Data d => d -> m d) -> Slug -> m Slug
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Slug -> m Slug
gmapQi :: Int -> (forall d. Data d => d -> u) -> Slug -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Slug -> u
gmapQ :: (forall d. Data d => d -> u) -> Slug -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Slug -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Slug -> r
gmapT :: (forall b. Data b => b -> b) -> Slug -> Slug
$cgmapT :: (forall b. Data b => b -> b) -> Slug -> Slug
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Slug)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Slug)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Slug)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Slug)
dataTypeOf :: Slug -> DataType
$cdataTypeOf :: Slug -> DataType
toConstr :: Slug -> Constr
$ctoConstr :: Slug -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Slug
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Slug
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Slug -> c Slug
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Slug -> c Slug
$cp1Data :: Typeable Slug
Data, (forall x. Slug -> Rep Slug x)
-> (forall x. Rep Slug x -> Slug) -> Generic Slug
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, [Slug] -> Encoding
[Slug] -> Value
Slug -> Encoding
Slug -> Value
(Slug -> Value)
-> (Slug -> Encoding)
-> ([Slug] -> Value)
-> ([Slug] -> Encoding)
-> ToJSON Slug
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Slug] -> Encoding
$ctoEncodingList :: [Slug] -> Encoding
toJSONList :: [Slug] -> Value
$ctoJSONList :: [Slug] -> Value
toEncoding :: Slug -> Encoding
$ctoEncoding :: Slug -> Encoding
toJSON :: Slug -> Value
$ctoJSON :: Slug -> Value
ToJSON, Value -> Parser [Slug]
Value -> Parser Slug
(Value -> Parser Slug) -> (Value -> Parser [Slug]) -> FromJSON 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)

-- | Decode an URL component into a `Slug` using `Network.URI.Encode`
decodeSlug :: Text -> Slug
decodeSlug :: Text -> Slug
decodeSlug =
  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
. ShowS
UE.decode ShowS -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString

-- | Encode a `Slug` into an URL component using `Network.URI.Encode`
encodeSlug :: Slug -> Text
encodeSlug :: Slug -> Text
encodeSlug =
  Text -> Text
UE.encodeText (Text -> Text) -> (Slug -> Text) -> Slug -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Slug -> Text
unSlug

instance IsString Slug where
  fromString :: HasCallStack => String -> Slug
  fromString :: String -> Slug
fromString (String -> Text
forall a. ToText a => a -> Text
toText -> Text
s) =
    if Text
"/" Text -> Text -> Bool
`T.isInfixOf` Text
s
      then Text -> Slug
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Slug cannot contain a slash: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s)
      else Text -> Slug
Slug (Text -> Text
unicodeNormalize Text
s)

-- Normalize varying non-ascii strings (in filepaths / slugs) to one
-- representation, so that they can be reliably linked to.
unicodeNormalize :: Text -> Text
unicodeNormalize :: Text -> Text
unicodeNormalize = NormalizationMode -> Text -> Text
UT.normalize NormalizationMode
UT.NFC (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. ToText a => a -> Text
toText