-- | The route type
-- Why I did this I don't know
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

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.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
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)

data RouteFragment
  = S' Text
    -- ^ Static string fragment
  | PS' String
    -- ^ Parameterised string fragment
  | ID' TypeRep
    -- ^ ID fragment
  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 )

-- | 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 ( (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 RequirementType
  = IDRequirement Type
  | PSRequirement Symbol

data RouteBuilder (reqstate :: [(RequirementType, RouteRequirement)]) = UnsafeMkRouteBuilder
  { RouteBuilder reqstate -> [RouteFragment]
route :: [RouteFragment]
  , RouteBuilder reqstate -> [(TypeRep, Word64)]
ids   :: [(TypeRep, Word64)]
  , 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 :: 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
$ 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 :: 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
$ Proxy s
forall k (t :: k). 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
$ Proxy a
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
$ Proxy s
forall k (t :: k). 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 ((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)

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

routeKey :: Route -> RouteKey
routeKey :: Route -> RouteKey
routeKey Route {Text
key :: Text
$sel:key:Route :: Route -> Text
key, Maybe (Snowflake Channel)
channelID :: Maybe (Snowflake Channel)
$sel:channelID:Route :: Route -> Maybe (Snowflake Channel)
channelID, Maybe (Snowflake Guild)
guildID :: Maybe (Snowflake Guild)
$sel:guildID:Route :: Route -> 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 :: 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 (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 (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
  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 (PS' String
s) = String -> Text
T.pack String
s
  goIdent (ID' TypeRep
t) = TypeRep -> Text
forall a. TextShow a => a -> Text
showt TypeRep
t