{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

{- | The route type
 Why I did this I don't know
-}
module Calamity.HTTP.Internal.Route (
  mkRouteBuilder,
  giveID,
  giveParam,
  buildRoute,
  routeKey,
  RouteKey,
  RouteBuilder,
  RouteRequirement,
  Route (path),
  S (..),
  PS (..),
  ID (..),
  RouteFragmentable (..),
) where

import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild
import Calamity.Types.Snowflake
import Data.Hashable
import Data.Kind
import Data.List (foldl')
import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Typeable
import Data.Word
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Network.HTTP.Req
import Optics.TH
import TextShow qualified

data RouteFragment
  = -- | Static string fragment
    S' Text
  | -- | Parameterised string fragment
    PS' String
  | -- | ID fragment
    ID' TypeRep
  deriving ((forall x. RouteFragment -> Rep RouteFragment x)
-> (forall x. Rep RouteFragment x -> RouteFragment)
-> Generic RouteFragment
forall x. Rep RouteFragment x -> RouteFragment
forall x. RouteFragment -> Rep RouteFragment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RouteFragment -> Rep RouteFragment x
from :: forall x. RouteFragment -> Rep RouteFragment x
$cto :: forall x. Rep RouteFragment x -> RouteFragment
to :: forall x. Rep RouteFragment x -> RouteFragment
Generic, Int -> RouteFragment -> ShowS
[RouteFragment] -> ShowS
RouteFragment -> String
(Int -> RouteFragment -> ShowS)
-> (RouteFragment -> String)
-> ([RouteFragment] -> ShowS)
-> Show RouteFragment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RouteFragment -> ShowS
showsPrec :: Int -> RouteFragment -> ShowS
$cshow :: RouteFragment -> String
show :: RouteFragment -> String
$cshowList :: [RouteFragment] -> ShowS
showList :: [RouteFragment] -> ShowS
Show, RouteFragment -> RouteFragment -> Bool
(RouteFragment -> RouteFragment -> Bool)
-> (RouteFragment -> RouteFragment -> Bool) -> Eq RouteFragment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RouteFragment -> RouteFragment -> Bool
== :: RouteFragment -> RouteFragment -> Bool
$c/= :: RouteFragment -> RouteFragment -> Bool
/= :: RouteFragment -> RouteFragment -> Bool
Eq)

-- | A static string fragment of a route
newtype S = S Text

-- | A parameterised string fragment of a route
data PS (s :: Symbol) = PS

-- | An id fragment of a route
data ID a = ID

instance Hashable RouteFragment

data RouteRequirement
  = NotNeeded
  | Required
  | Satisfied
  deriving (Int -> RouteRequirement -> ShowS
[RouteRequirement] -> ShowS
RouteRequirement -> String
(Int -> RouteRequirement -> ShowS)
-> (RouteRequirement -> String)
-> ([RouteRequirement] -> ShowS)
-> Show RouteRequirement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RouteRequirement -> ShowS
showsPrec :: Int -> RouteRequirement -> ShowS
$cshow :: RouteRequirement -> String
show :: RouteRequirement -> String
$cshowList :: [RouteRequirement] -> ShowS
showList :: [RouteRequirement] -> ShowS
Show, RouteRequirement -> RouteRequirement -> Bool
(RouteRequirement -> RouteRequirement -> Bool)
-> (RouteRequirement -> RouteRequirement -> Bool)
-> Eq RouteRequirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RouteRequirement -> RouteRequirement -> Bool
== :: RouteRequirement -> RouteRequirement -> Bool
$c/= :: RouteRequirement -> RouteRequirement -> Bool
/= :: RouteRequirement -> RouteRequirement -> Bool
Eq)

data RequirementType
  = IDRequirement Type
  | PSRequirement Symbol

data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder
  { forall (reqstate :: [(RequirementType, RouteRequirement)]).
RouteBuilder reqstate -> [RouteFragment]
route :: [RouteFragment]
  , forall (reqstate :: [(RequirementType, RouteRequirement)]).
RouteBuilder reqstate -> [(TypeRep, Word64)]
ids :: [(TypeRep, Word64)]
  , forall (reqstate :: [(RequirementType, RouteRequirement)]).
RouteBuilder reqstate -> [(String, Text)]
params :: [(String, Text)]
  }

mkRouteBuilder :: RouteBuilder '[]
mkRouteBuilder :: RouteBuilder '[]
mkRouteBuilder = [RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder '[]
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder [] [] []

giveID ::
  forall t reqs.
  Typeable t =>
  Snowflake t ->
  RouteBuilder reqs ->
  RouteBuilder ('( 'IDRequirement t, 'Satisfied) ': reqs)
giveID :: forall t (reqs :: [(RequirementType, RouteRequirement)]).
Typeable t =>
Snowflake t
-> RouteBuilder reqs
-> RouteBuilder ('( 'IDRequirement t, 'Satisfied) : reqs)
giveID (Snowflake Word64
id) (UnsafeMkRouteBuilder [RouteFragment]
route [(TypeRep, Word64)]
ids [(String, Text)]
params) =
  [RouteFragment]
-> [(TypeRep, Word64)]
-> [(String, Text)]
-> RouteBuilder ('( 'IDRequirement t, 'Satisfied) : reqs)
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder [RouteFragment]
route ((Proxy t -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy t -> TypeRep) -> Proxy t -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @t, Word64
id) (TypeRep, Word64) -> [(TypeRep, Word64)] -> [(TypeRep, Word64)]
forall a. a -> [a] -> [a]
: [(TypeRep, Word64)]
ids) [(String, Text)]
params

giveParam ::
  forall (s :: Symbol) reqs.
  KnownSymbol s =>
  Text ->
  RouteBuilder reqs ->
  RouteBuilder ('( 'PSRequirement s, 'Satisfied) ': reqs)
giveParam :: forall (s :: Symbol)
       (reqs :: [(RequirementType, RouteRequirement)]).
KnownSymbol s =>
Text
-> RouteBuilder reqs
-> RouteBuilder ('( 'PSRequirement s, 'Satisfied) : reqs)
giveParam Text
value (UnsafeMkRouteBuilder [RouteFragment]
route [(TypeRep, Word64)]
ids [(String, Text)]
params) =
  [RouteFragment]
-> [(TypeRep, Word64)]
-> [(String, Text)]
-> RouteBuilder ('( 'PSRequirement s, 'Satisfied) : reqs)
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder [RouteFragment]
route [(TypeRep, Word64)]
ids ((Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s, Text
value) (String, Text) -> [(String, Text)] -> [(String, Text)]
forall a. a -> [a] -> [a]
: [(String, Text)]
params)

type family (&&) (a :: Bool) (b :: Bool) :: Bool where
  'True && 'True = 'True
  _ && _ = 'False

type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where
  Lookup k ('(k, v) ': xs) = 'Just v
  Lookup k ('(_, v) ': xs) = Lookup k xs
  Lookup _ '[] = 'Nothing

type family IsElem (x :: k) (l :: [k]) :: Bool where
  IsElem _ '[] = 'False
  IsElem k (k : _) = 'True
  IsElem k (_ : xs) = IsElem k xs

type family EnsureFulfilled (reqs :: [(RequirementType, RouteRequirement)]) :: Constraint where
  EnsureFulfilled reqs = EnsureFulfilledInner reqs '[] 'True

type family EnsureFulfilledInner (reqs :: [(RequirementType, RouteRequirement)]) (seen :: [RequirementType]) (ok :: Bool) :: Constraint where
  EnsureFulfilledInner '[] _ 'True = ()
  EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok
  EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) ok
  EnsureFulfilledInner ('(k, 'Required) ': xs) seen ok = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok)

type family AddRequired k (reqs :: [(RequirementType, RouteRequirement)]) :: [(RequirementType, RouteRequirement)] where
  AddRequired k reqs = '(k, AddRequiredInner (Lookup k reqs)) ': reqs

type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where
  AddRequiredInner ('Just 'Required) = 'Required
  AddRequiredInner ('Just 'Satisfied) = 'Satisfied
  AddRequiredInner ('Just 'NotNeeded) = 'Required
  AddRequiredInner 'Nothing = 'Required

class Typeable a => RouteFragmentable a reqs where
  type ConsRes a reqs

  (//) :: RouteBuilder reqs -> a -> ConsRes a reqs

instance RouteFragmentable S reqs where
  type ConsRes S reqs = RouteBuilder reqs

  (UnsafeMkRouteBuilder [RouteFragment]
r [(TypeRep, Word64)]
ids [(String, Text)]
params) // :: RouteBuilder reqs -> S -> ConsRes S reqs
// (S Text
t) =
    [RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqs
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder ([RouteFragment]
r [RouteFragment] -> [RouteFragment] -> [RouteFragment]
forall a. Semigroup a => a -> a -> a
<> [Text -> RouteFragment
S' Text
t]) [(TypeRep, Word64)]
ids [(String, Text)]
params

instance Typeable a => RouteFragmentable (ID (a :: Type)) (reqs :: [(RequirementType, RouteRequirement)]) where
  type ConsRes (ID a) reqs = RouteBuilder (AddRequired ('IDRequirement a) reqs)

  (UnsafeMkRouteBuilder [RouteFragment]
r [(TypeRep, Word64)]
ids [(String, Text)]
params) // :: RouteBuilder reqs -> ID a -> ConsRes (ID a) reqs
// ID a
ID =
    [RouteFragment]
-> [(TypeRep, Word64)]
-> [(String, Text)]
-> RouteBuilder
     ('( 'IDRequirement a,
         AddRequiredInner (Lookup ('IDRequirement a) reqs))
        : reqs)
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder ([RouteFragment]
r [RouteFragment] -> [RouteFragment] -> [RouteFragment]
forall a. Semigroup a => a -> a -> a
<> [TypeRep -> RouteFragment
ID' (TypeRep -> RouteFragment) -> TypeRep -> RouteFragment
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a]) [(TypeRep, Word64)]
ids [(String, Text)]
params

instance KnownSymbol s => RouteFragmentable (PS s) (reqs :: [(RequirementType, RouteRequirement)]) where
  type ConsRes (PS s) reqs = RouteBuilder (AddRequired ('PSRequirement s) reqs)

  (UnsafeMkRouteBuilder [RouteFragment]
r [(TypeRep, Word64)]
ids [(String, Text)]
params) // :: RouteBuilder reqs -> PS s -> ConsRes (PS s) reqs
// PS s
PS =
    [RouteFragment]
-> [(TypeRep, Word64)]
-> [(String, Text)]
-> RouteBuilder
     ('( 'PSRequirement s,
         AddRequiredInner (Lookup ('PSRequirement s) reqs))
        : reqs)
forall (reqstate :: [(RequirementType, RouteRequirement)]).
[RouteFragment]
-> [(TypeRep, Word64)] -> [(String, Text)] -> RouteBuilder reqstate
UnsafeMkRouteBuilder ([RouteFragment]
r [RouteFragment] -> [RouteFragment] -> [RouteFragment]
forall a. Semigroup a => a -> a -> a
<> [String -> RouteFragment
PS' (String -> RouteFragment) -> String -> RouteFragment
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @s]) [(TypeRep, Word64)]
ids [(String, Text)]
params

infixl 5 //

data Route = Route
  { Route -> Url 'Https
path :: Url 'Https
  , Route -> Text
key :: Text
  , Route -> Maybe (Snowflake Channel)
channelID :: Maybe (Snowflake Channel)
  , Route -> Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
  }
  deriving (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
(Int -> Route -> ShowS)
-> (Route -> String) -> ([Route] -> ShowS) -> Show Route
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Route -> ShowS
showsPrec :: Int -> Route -> ShowS
$cshow :: Route -> String
show :: Route -> String
$cshowList :: [Route] -> ShowS
showList :: [Route] -> ShowS
Show)

type RouteKey = (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild))

routeKey :: Route -> RouteKey
routeKey :: Route -> RouteKey
routeKey Route {Text
$sel:key:Route :: Route -> Text
key :: Text
key, Maybe (Snowflake Channel)
$sel:channelID:Route :: Route -> Maybe (Snowflake Channel)
channelID :: Maybe (Snowflake Channel)
channelID, Maybe (Snowflake Guild)
$sel:guildID:Route :: Route -> Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
guildID} = (Text
key, Maybe (Snowflake Channel)
channelID, Maybe (Snowflake Guild)
guildID)

baseURL :: Url 'Https
baseURL :: Url 'Https
baseURL = Text -> Url 'Https
https Text
"discord.com" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"api" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"v10"

buildRoute ::
  forall (reqs :: [(RequirementType, RouteRequirement)]).
  EnsureFulfilled reqs =>
  RouteBuilder reqs ->
  Route
buildRoute :: forall (reqs :: [(RequirementType, RouteRequirement)]).
EnsureFulfilled reqs =>
RouteBuilder reqs -> Route
buildRoute (UnsafeMkRouteBuilder [RouteFragment]
route [(TypeRep, Word64)]
ids [(String, Text)]
params) =
  Url 'Https
-> Text
-> Maybe (Snowflake Channel)
-> Maybe (Snowflake Guild)
-> Route
Route
    ((Url 'Https -> Text -> Url 'Https)
-> Url 'Https -> [Text] -> Url 'Https
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
(/:) Url 'Https
baseURL ([Text] -> Url 'Https) -> [Text] -> Url 'Https
forall a b. (a -> b) -> a -> b
$ (RouteFragment -> Text) -> [RouteFragment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RouteFragment -> Text
goRoute [RouteFragment]
route)
    ([Text] -> Text
T.concat ((RouteFragment -> Text) -> [RouteFragment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RouteFragment -> Text
goKey [RouteFragment]
route))
    (Word64 -> Snowflake Channel
forall t. Word64 -> Snowflake t
Snowflake (Word64 -> Snowflake Channel)
-> Maybe Word64 -> Maybe (Snowflake Channel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeRep -> [(TypeRep, Word64)] -> Maybe Word64
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Proxy Channel -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Channel)) [(TypeRep, Word64)]
ids)
    (Word64 -> Snowflake Guild
forall t. Word64 -> Snowflake t
Snowflake (Word64 -> Snowflake Guild)
-> Maybe Word64 -> Maybe (Snowflake Guild)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeRep -> [(TypeRep, Word64)] -> Maybe Word64
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Proxy Guild -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Guild)) [(TypeRep, Word64)]
ids)
  where
    goRoute :: RouteFragment -> Text
goRoute (S' Text
t) = Text
t
    goRoute (PS' String
t) = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> [(String, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
t [(String, Text)]
params
    goRoute (ID' TypeRep
t) = Word64 -> Text
forall a. TextShow a => a -> Text
TextShow.showt (Word64 -> Text)
-> (Maybe Word64 -> Word64) -> Maybe Word64 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Word64 -> Word64
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Word64 -> Text) -> Maybe Word64 -> Text
forall a b. (a -> b) -> a -> b
$ TypeRep -> [(TypeRep, Word64)] -> Maybe Word64
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TypeRep
t [(TypeRep, Word64)]
ids

    goKey :: RouteFragment -> Text
goKey (S' Text
t) = Text
t
    goKey (PS' String
t) = String -> Text
T.pack String
t
    goKey (ID' TypeRep
t) = TypeRep -> Text
forall a. TextShow a => a -> Text
TextShow.showt TypeRep
t

$(makeFieldLabelsNoPrefix ''Route)