-- | The route type
-- Why I did this I don't know
{-# 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           Data.List ( foldl' )

import           Network.HTTP.Req

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 Word64
id) (UnsafeMkRouteBuilder [RouteFragment]
route [(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 [RouteFragment]
r [(TypeRep, Word64)]
ids) // :: RouteBuilder ids -> S -> ConsRes S ids
// (S Text
t) =
    [RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder ids
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder ([RouteFragment]
r [RouteFragment] -> [RouteFragment] -> [RouteFragment]
forall a. Semigroup a => a -> a -> a
<> [Text -> RouteFragment
S' Text
t]) [(TypeRep, Word64)]
ids

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

  (UnsafeMkRouteBuilder [RouteFragment]
r [(TypeRep, Word64)]
ids) // :: RouteBuilder ids -> ID a -> ConsRes (ID a) ids
// ID a
ID =
    [RouteFragment]
-> [(TypeRep, Word64)]
-> RouteBuilder ('(a, AddRequiredInner (Lookup a ids)) : ids)
forall (idState :: [(*, RouteRequirement)]).
[RouteFragment] -> [(TypeRep, Word64)] -> RouteBuilder idState
UnsafeMkRouteBuilder ([RouteFragment]
r [RouteFragment] -> [RouteFragment] -> [RouteFragment]
forall a. Semigroup a => a -> a -> a
<> [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))]) [(TypeRep, Word64)]
ids

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 ((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 Int
s (Route Url 'Https
_ Text
ident Maybe (Snowflake Channel)
c 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 :: 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
"v8"

buildRoute
  :: forall (ids :: [(Type, RouteRequirement)])
   . EnsureFulfilled ids
  => RouteBuilder ids
  -> Route
buildRoute :: RouteBuilder ids -> Route
buildRoute (UnsafeMkRouteBuilder [RouteFragment]
route [(TypeRep, Word64)]
ids) = Url 'Https
-> Text
-> Maybe (Snowflake Channel)
-> Maybe (Snowflake Guild)
-> Route
Route
  ((Url 'Https -> Text -> Url 'Https)
-> Url 'Https -> [Text] -> Url 'Https
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
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 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 (Proxy Channel
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 (Proxy Guild
forall k (t :: k). Proxy t
Proxy @Guild)) [(TypeRep, Word64)]
ids)
 where
  goR :: RouteFragment -> Text
goR (S'  Text
t) = Text
t
  goR (ID' 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'  Text
t) = Text
t
  goIdent (ID' TypeRep
t) = TypeRep -> Text
forall a. TextShow a => a -> Text
showt TypeRep
t