{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Calamity.HTTP.Internal.Route
( mkRouteBuilder
, giveID
, buildRoute
, RouteBuilder
, RouteRequirement
, Route(path)
, S(..)
, 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.Maybe ( fromJust )
import Data.Text ( Text )
import qualified Data.Text as T
import Data.Typeable
import Data.Word
import GHC.Generics hiding ( S )
import TextShow
data RouteFragment
= S' Text
| 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
$cto :: forall x. Rep RouteFragment x -> RouteFragment
$cfrom :: forall x. RouteFragment -> Rep RouteFragment x
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
showList :: [RouteFragment] -> ShowS
$cshowList :: [RouteFragment] -> ShowS
show :: RouteFragment -> String
$cshow :: RouteFragment -> String
showsPrec :: Int -> RouteFragment -> ShowS
$cshowsPrec :: Int -> RouteFragment -> ShowS
Show, RouteFragment -> RouteFragment -> Bool
(RouteFragment -> RouteFragment -> Bool)
-> (RouteFragment -> RouteFragment -> Bool) -> Eq RouteFragment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteFragment -> RouteFragment -> Bool
$c/= :: RouteFragment -> RouteFragment -> Bool
== :: RouteFragment -> RouteFragment -> Bool
$c== :: RouteFragment -> RouteFragment -> Bool
Eq )
newtype S = S Text
data ID a = ID
instance Hashable RouteFragment
data RouteRequirement
= NotNeeded
| Required
| Satisfied
deriving ( (forall x. RouteRequirement -> Rep RouteRequirement x)
-> (forall x. Rep RouteRequirement x -> RouteRequirement)
-> Generic RouteRequirement
forall x. Rep RouteRequirement x -> RouteRequirement
forall x. RouteRequirement -> Rep RouteRequirement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RouteRequirement x -> RouteRequirement
$cfrom :: forall x. RouteRequirement -> Rep RouteRequirement x
Generic, 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
showList :: [RouteRequirement] -> ShowS
$cshowList :: [RouteRequirement] -> ShowS
show :: RouteRequirement -> String
$cshow :: RouteRequirement -> String
showsPrec :: Int -> RouteRequirement -> ShowS
$cshowsPrec :: Int -> RouteRequirement -> ShowS
Show, RouteRequirement -> RouteRequirement -> Bool
(RouteRequirement -> RouteRequirement -> Bool)
-> (RouteRequirement -> RouteRequirement -> Bool)
-> Eq RouteRequirement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteRequirement -> RouteRequirement -> Bool
$c/= :: RouteRequirement -> RouteRequirement -> Bool
== :: RouteRequirement -> RouteRequirement -> Bool
$c== :: RouteRequirement -> RouteRequirement -> Bool
Eq )
data RouteBuilder (idState :: [(Type, RouteRequirement)]) = UnsafeMkRouteBuilder
{ RouteBuilder idState -> [RouteFragment]
route :: [RouteFragment]
, RouteBuilder idState -> [(TypeRep, Word64)]
ids :: [(TypeRep, Word64)]
}
mkRouteBuilder :: RouteBuilder '[]
mkRouteBuilder :: RouteBuilder '[]
mkRouteBuilder = [RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder '[]
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder [] []
giveID
:: forall k ids
. Typeable k
=> Snowflake k
-> RouteBuilder ids
-> RouteBuilder ('(k, 'Satisfied) ': ids)
giveID :: Snowflake k
-> RouteBuilder ids -> RouteBuilder ('(k, 'Satisfied) : ids)
giveID (Snowflake id :: Word64
id) (UnsafeMkRouteBuilder route :: [RouteFragment]
route ids :: [(TypeRep, Word64)]
ids) =
[RouteFragment]
-> [(TypeRep, Word64)] -> RouteBuilder ('(k, 'Satisfied) : ids)
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder [RouteFragment]
route ((Proxy k -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy k
forall k (t :: k). Proxy t
Proxy @k), Word64
id) (TypeRep, Word64) -> [(TypeRep, Word64)] -> [(TypeRep, Word64)]
forall a. a -> [a] -> [a]
: [(TypeRep, Word64)]
ids)
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 (ids :: [(k, RouteRequirement)]) :: Constraint where
EnsureFulfilled ids = EnsureFulfilledInner ids '[] 'True
type family EnsureFulfilledInner (ids :: [(k, RouteRequirement)]) (seen :: [k]) (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 (ids :: [(Type, RouteRequirement)]) :: [(Type, RouteRequirement)] where
AddRequired k ids = '(k, AddRequiredInner (Lookup k ids)) ': ids
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 ids where
type ConsRes a ids
(//) :: RouteBuilder ids -> a -> ConsRes a ids
instance RouteFragmentable S ids where
type ConsRes S ids = RouteBuilder ids
(UnsafeMkRouteBuilder r :: [RouteFragment]
r ids :: [(TypeRep, Word64)]
ids) // :: RouteBuilder ids -> S -> ConsRes S ids
// (S t :: Text
t) =
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder ids
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder (Text -> RouteFragment
S' Text
t RouteFragment -> [RouteFragment] -> [RouteFragment]
forall a. a -> [a] -> [a]
: [RouteFragment]
r) [(TypeRep, Word64)]
ids
instance Typeable a => RouteFragmentable (ID (a :: Type)) (ids :: [(Type, RouteRequirement)]) where
type ConsRes (ID a) ids = RouteBuilder (AddRequired a ids)
(UnsafeMkRouteBuilder r :: [RouteFragment]
r ids :: [(TypeRep, Word64)]
ids) // :: RouteBuilder ids -> ID a -> ConsRes (ID a) ids
// ID =
[RouteFragment]
-> [(TypeRep, Word64)]
-> RouteBuilder ('(a, AddRequiredInner (Lookup a ids)) : ids)
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder (TypeRep -> RouteFragment
ID' (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a)) RouteFragment -> [RouteFragment] -> [RouteFragment]
forall a. a -> [a] -> [a]
: [RouteFragment]
r) [(TypeRep, Word64)]
ids
infixl 5 //
data Route = Route
{ Route -> Text
path :: Text
, Route -> Text
key :: Text
, Route -> Maybe (Snowflake Channel)
channelID :: Maybe (Snowflake Channel)
, Route -> Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
} deriving ((forall x. Route -> Rep Route x)
-> (forall x. Rep Route x -> Route) -> Generic Route
forall x. Rep Route x -> Route
forall x. Route -> Rep Route x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Route x -> Route
$cfrom :: forall x. Route -> Rep Route x
Generic, 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
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show, Route -> Route -> Bool
(Route -> Route -> Bool) -> (Route -> Route -> Bool) -> Eq Route
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route -> Route -> Bool
$c/= :: Route -> Route -> Bool
== :: Route -> Route -> Bool
$c== :: Route -> Route -> Bool
Eq)
instance Hashable Route where
hashWithSalt :: Int -> Route -> Int
hashWithSalt s :: Int
s (Route _ ident :: Text
ident c :: Maybe (Snowflake Channel)
c g :: Maybe (Snowflake Guild)
g) = Int
-> (Text, Maybe (Snowflake Channel), Maybe (Snowflake Guild))
-> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Text
ident, Maybe (Snowflake Channel)
c, Maybe (Snowflake Guild)
g)
baseURL :: Text
baseURL :: Text
baseURL = "https://discordapp.com/api/v7"
buildRoute
:: forall (ids :: [(Type, RouteRequirement)])
. EnsureFulfilled ids
=> RouteBuilder ids
-> Route
buildRoute :: RouteBuilder ids -> Route
buildRoute (UnsafeMkRouteBuilder route :: [RouteFragment]
route ids :: [(TypeRep, Word64)]
ids) = Text
-> Text
-> Maybe (Snowflake Channel)
-> Maybe (Snowflake Guild)
-> Route
Route
(Text -> [Text] -> Text
T.intercalate "/" (Text
baseURL Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (RouteFragment -> Text) -> [RouteFragment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RouteFragment -> Text
goR [RouteFragment]
route'))
([Text] -> Text
T.concat ((RouteFragment -> Text) -> [RouteFragment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map RouteFragment -> Text
goIdent [RouteFragment]
route'))
(Word64 -> Snowflake Channel
forall k (t :: k). 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 (Proxy Channel
forall k (t :: k). Proxy t
Proxy @Channel)) [(TypeRep, Word64)]
ids)
(Word64 -> Snowflake Guild
forall k (t :: k). 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 (Proxy Guild
forall k (t :: k). Proxy t
Proxy @Guild)) [(TypeRep, Word64)]
ids)
where
route' :: [RouteFragment]
route' = [RouteFragment] -> [RouteFragment]
forall a. [a] -> [a]
reverse [RouteFragment]
route
goR :: RouteFragment -> Text
goR (S' t :: Text
t) = Text
t
goR (ID' t :: TypeRep
t) = Word64 -> Text
forall a. TextShow a => a -> Text
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
goIdent :: RouteFragment -> Text
goIdent (S' t :: Text
t) = Text
t
goIdent (ID' t :: TypeRep
t) = TypeRep -> Text
forall a. TextShow a => a -> Text
showt TypeRep
t