{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ConstraintKinds #-}

module MatrixBot.MatrixApi.Types.MEventTypes
     ( MEventType (..)
     , MEventTypeOneOf (..)
     , mEventTypeToString
     , mEventTypeOneOfToMEventType
     ) where

import GHC.TypeLits

import Data.Function (on)
import Data.List (find)
import Data.Proxy
import Data.String (IsString (fromString))
import Data.Typeable
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson

import Servant.API (ToHttpApiData (..))


-- | Matrix event types enum
data MEventType
  = MAnnotationType
  | MReactionType
  | MRoomMessageType
  | MLoginPasswordType
  deriving stock (Int -> MEventType -> ShowS
[MEventType] -> ShowS
MEventType -> String
(Int -> MEventType -> ShowS)
-> (MEventType -> String)
-> ([MEventType] -> ShowS)
-> Show MEventType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MEventType -> ShowS
showsPrec :: Int -> MEventType -> ShowS
$cshow :: MEventType -> String
show :: MEventType -> String
$cshowList :: [MEventType] -> ShowS
showList :: [MEventType] -> ShowS
Show, MEventType -> MEventType -> Bool
(MEventType -> MEventType -> Bool)
-> (MEventType -> MEventType -> Bool) -> Eq MEventType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MEventType -> MEventType -> Bool
== :: MEventType -> MEventType -> Bool
$c/= :: MEventType -> MEventType -> Bool
/= :: MEventType -> MEventType -> Bool
Eq, Int -> MEventType
MEventType -> Int
MEventType -> [MEventType]
MEventType -> MEventType
MEventType -> MEventType -> [MEventType]
MEventType -> MEventType -> MEventType -> [MEventType]
(MEventType -> MEventType)
-> (MEventType -> MEventType)
-> (Int -> MEventType)
-> (MEventType -> Int)
-> (MEventType -> [MEventType])
-> (MEventType -> MEventType -> [MEventType])
-> (MEventType -> MEventType -> [MEventType])
-> (MEventType -> MEventType -> MEventType -> [MEventType])
-> Enum MEventType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MEventType -> MEventType
succ :: MEventType -> MEventType
$cpred :: MEventType -> MEventType
pred :: MEventType -> MEventType
$ctoEnum :: Int -> MEventType
toEnum :: Int -> MEventType
$cfromEnum :: MEventType -> Int
fromEnum :: MEventType -> Int
$cenumFrom :: MEventType -> [MEventType]
enumFrom :: MEventType -> [MEventType]
$cenumFromThen :: MEventType -> MEventType -> [MEventType]
enumFromThen :: MEventType -> MEventType -> [MEventType]
$cenumFromTo :: MEventType -> MEventType -> [MEventType]
enumFromTo :: MEventType -> MEventType -> [MEventType]
$cenumFromThenTo :: MEventType -> MEventType -> MEventType -> [MEventType]
enumFromThenTo :: MEventType -> MEventType -> MEventType -> [MEventType]
Enum, MEventType
MEventType -> MEventType -> Bounded MEventType
forall a. a -> a -> Bounded a
$cminBound :: MEventType
minBound :: MEventType
$cmaxBound :: MEventType
maxBound :: MEventType
Bounded)

type family MEventTypeToString (a ∷ MEventType) where
  MEventTypeToString 'MAnnotationType = "m.annotation"
  MEventTypeToString 'MReactionType = "m.reaction"
  MEventTypeToString 'MRoomMessageType = "m.room.message"
  MEventTypeToString 'MLoginPasswordType = "m.login.password"

mEventTypeToString ∷ IsString s ⇒ MEventType → s
mEventTypeToString :: forall s. IsString s => MEventType -> s
mEventTypeToString = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (MEventType -> String) -> MEventType -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  MEventType
MAnnotationType → Proxy "m.annotation" -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy "m.annotation" -> String) -> Proxy "m.annotation" -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(MEventTypeToString 'MAnnotationType)
  MEventType
MReactionType → Proxy "m.reaction" -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy "m.reaction" -> String) -> Proxy "m.reaction" -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(MEventTypeToString 'MReactionType)
  MEventType
MRoomMessageType → Proxy "m.room.message" -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy "m.room.message" -> String)
-> Proxy "m.room.message" -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(MEventTypeToString 'MRoomMessageType)
  MEventType
MLoginPasswordType → Proxy "m.login.password" -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy "m.login.password" -> String)
-> Proxy "m.login.password" -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @(MEventTypeToString 'MLoginPasswordType)

-- | Limited/restricted subset of "MEventType"
data MEventTypeOneOf (types ∷ [MEventType]) where
  MAnnotationTypeOneOf ∷ OneOf 'MAnnotationType types ~ 'True ⇒ MEventTypeOneOf types
  MReactionTypeOneOf ∷ OneOf 'MReactionType types ~ 'True ⇒ MEventTypeOneOf types
  MRoomMessageTypeOneOf ∷ OneOf 'MRoomMessageType types ~ 'True ⇒ MEventTypeOneOf types
  MLoginPasswordTypeOneOf ∷ OneOf 'MLoginPasswordType types ~ 'True ⇒ MEventTypeOneOf types

mEventTypeOneOfToMEventType ∷ MEventTypeOneOf (t ': ts) → MEventType
mEventTypeOneOfToMEventType :: forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType = \case
  MEventTypeOneOf (t : ts)
MAnnotationTypeOneOf → MEventType
MAnnotationType
  MEventTypeOneOf (t : ts)
MReactionTypeOneOf → MEventType
MReactionType
  MEventTypeOneOf (t : ts)
MRoomMessageTypeOneOf → MEventType
MRoomMessageType
  MEventTypeOneOf (t : ts)
MLoginPasswordTypeOneOf → MEventType
MLoginPasswordType

instance (ItemParser t ts to x xs, t ~ 'MAnnotationType) ⇒ ToParser '(to, 'MAnnotationType ': ts) where
  toParser :: Proxy '(to, 'MAnnotationType : ts)
-> Value
-> Parser (MEventTypeOneOf (Fst '(to, 'MAnnotationType : ts)))
toParser Proxy '(to, 'MAnnotationType : ts)
Proxy = Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
forall (t :: MEventType) (ts :: [MEventType]) (to :: [MEventType])
       (x :: MEventType) (xs :: [MEventType]).
ItemParser t ts to x xs =>
Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
genericToParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(to, t ': ts)) MEventTypeOneOf to
forall (types :: [MEventType]).
(OneOf 'MAnnotationType types ~ 'True) =>
MEventTypeOneOf types
MAnnotationTypeOneOf
instance (ItemParser t ts to x xs, t ~ 'MReactionType) ⇒ ToParser '(to, 'MReactionType ': ts) where
  toParser :: Proxy '(to, 'MReactionType : ts)
-> Value
-> Parser (MEventTypeOneOf (Fst '(to, 'MReactionType : ts)))
toParser Proxy '(to, 'MReactionType : ts)
Proxy = Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
forall (t :: MEventType) (ts :: [MEventType]) (to :: [MEventType])
       (x :: MEventType) (xs :: [MEventType]).
ItemParser t ts to x xs =>
Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
genericToParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(to, t ': ts)) MEventTypeOneOf to
forall (types :: [MEventType]).
(OneOf 'MReactionType types ~ 'True) =>
MEventTypeOneOf types
MReactionTypeOneOf
instance (ItemParser t ts to x xs, t ~ 'MRoomMessageType) ⇒ ToParser '(to, 'MRoomMessageType ': ts) where
  toParser :: Proxy '(to, 'MRoomMessageType : ts)
-> Value
-> Parser (MEventTypeOneOf (Fst '(to, 'MRoomMessageType : ts)))
toParser Proxy '(to, 'MRoomMessageType : ts)
Proxy = Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
forall (t :: MEventType) (ts :: [MEventType]) (to :: [MEventType])
       (x :: MEventType) (xs :: [MEventType]).
ItemParser t ts to x xs =>
Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
genericToParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(to, t ': ts)) MEventTypeOneOf to
forall (types :: [MEventType]).
(OneOf 'MRoomMessageType types ~ 'True) =>
MEventTypeOneOf types
MRoomMessageTypeOneOf
instance (ItemParser t ts to x xs, t ~ 'MLoginPasswordType) ⇒ ToParser '(to, 'MLoginPasswordType ': ts) where
  toParser :: Proxy '(to, 'MLoginPasswordType : ts)
-> Value
-> Parser (MEventTypeOneOf (Fst '(to, 'MLoginPasswordType : ts)))
toParser Proxy '(to, 'MLoginPasswordType : ts)
Proxy = Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
forall (t :: MEventType) (ts :: [MEventType]) (to :: [MEventType])
       (x :: MEventType) (xs :: [MEventType]).
ItemParser t ts to x xs =>
Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
genericToParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(to, t ': ts)) MEventTypeOneOf to
forall (types :: [MEventType]).
(OneOf 'MLoginPasswordType types ~ 'True) =>
MEventTypeOneOf types
MLoginPasswordTypeOneOf


instance Aeson.ToJSON MEventType where
  toJSON :: MEventType -> Value
toJSON = Text -> Value
Aeson.String (Text -> Value) -> (MEventType -> Text) -> MEventType -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MEventType -> Text
forall s. IsString s => MEventType -> s
mEventTypeToString

instance Aeson.FromJSON MEventType where
  parseJSON ∷ ∀a. (a ~ MEventType) ⇒ Aeson.Value → Aeson.Parser a
  parseJSON :: forall a. (a ~ MEventType) => Value -> Parser a
parseJSON Value
jsonInput
    = Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Value -> Parser a
forall a. String -> Value -> Parser a
Aeson.typeMismatch (TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy a -> TypeRep) -> Proxy a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> String) -> Proxy a -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) Value
jsonInput) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe a -> Parser a) -> Maybe a -> Parser a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Value
jsonInput Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
==) (Value -> Bool) -> (a -> Value) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON) [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound ∷ a]


-- Matching non-empty list (it’s impossible to have any value of an empty list)
instance Show (MEventTypeOneOf (t ': ts)) where
  show :: MEventTypeOneOf (t : ts) -> String
show = MEventType -> String
forall a. Show a => a -> String
show (MEventType -> String)
-> (MEventTypeOneOf (t : ts) -> MEventType)
-> MEventTypeOneOf (t : ts)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MEventTypeOneOf (t : ts) -> MEventType
forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType

instance Eq (MEventTypeOneOf (t ': ts)) where
  == :: MEventTypeOneOf (t : ts) -> MEventTypeOneOf (t : ts) -> Bool
(==) = MEventType -> MEventType -> Bool
forall a. Eq a => a -> a -> Bool
(==) (MEventType -> MEventType -> Bool)
-> (MEventTypeOneOf (t : ts) -> MEventType)
-> MEventTypeOneOf (t : ts)
-> MEventTypeOneOf (t : ts)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` MEventTypeOneOf (t : ts) -> MEventType
forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType

instance ToHttpApiData (MEventTypeOneOf (t ': ts)) where
  toUrlPiece :: MEventTypeOneOf (t : ts) -> Text
toUrlPiece = MEventType -> Text
forall s. IsString s => MEventType -> s
mEventTypeToString (MEventType -> Text)
-> (MEventTypeOneOf (t : ts) -> MEventType)
-> MEventTypeOneOf (t : ts)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MEventTypeOneOf (t : ts) -> MEventType
forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType

instance Aeson.ToJSON (MEventTypeOneOf (t ': ts)) where
  toJSON :: MEventTypeOneOf (t : ts) -> Value
toJSON = MEventType -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (MEventType -> Value)
-> (MEventTypeOneOf (t : ts) -> MEventType)
-> MEventTypeOneOf (t : ts)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MEventTypeOneOf (t : ts) -> MEventType
forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType

instance ToParser '(t ': ts, t ': ts) ⇒ Aeson.FromJSON (MEventTypeOneOf (t ': ts)) where
  parseJSON :: Value -> Parser (MEventTypeOneOf (t : ts))
parseJSON = Proxy '(t : ts, t : ts)
-> Value -> Parser (MEventTypeOneOf (Fst '(t : ts, t : ts)))
forall (a :: ([MEventType], [MEventType])).
ToParser a =>
Proxy a -> Value -> Parser (MEventTypeOneOf (Fst a))
toParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(t ': ts, t ': ts))


-- | Serialize a list of "MEventType"s to a JSON parser
class ToParser (a ∷ ([MEventType], [MEventType])) where
  toParser ∷ Proxy a → Aeson.Value → Aeson.Parser (MEventTypeOneOf (Fst a))

instance ToParser '(x ': xs, '[]) where
  toParser :: Proxy '(x : xs, '[])
-> Value -> Parser (MEventTypeOneOf (Fst '(x : xs, '[])))
toParser Proxy '(x : xs, '[])
Proxy = String -> Value -> Parser (MEventTypeOneOf (x : xs))
forall a. String -> Value -> Parser a
Aeson.typeMismatch String
"MEventTypeOneOf"

type ItemParser t ts to x xs = (to ~ x ': xs, OneOf t to ~ 'True, ToParser '(to, ts))

genericToParser
  ∷ ∀ t ts to x xs
  . ItemParser t ts to x xs
  ⇒ Proxy '(to, t ': ts)
  → MEventTypeOneOf to
  → Aeson.Value
  → Aeson.Parser (MEventTypeOneOf to)
genericToParser :: forall (t :: MEventType) (ts :: [MEventType]) (to :: [MEventType])
       (x :: MEventType) (xs :: [MEventType]).
ItemParser t ts to x xs =>
Proxy '(to, t : ts)
-> MEventTypeOneOf to -> Value -> Parser (MEventTypeOneOf to)
genericToParser Proxy '(to, t : ts)
Proxy MEventTypeOneOf to
x Value
j
  | Value
j Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== MEventType -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (MEventTypeOneOf (x : xs) -> MEventType
forall (t :: MEventType) (ts :: [MEventType]).
MEventTypeOneOf (t : ts) -> MEventType
mEventTypeOneOfToMEventType MEventTypeOneOf to
MEventTypeOneOf (x : xs)
x) = MEventTypeOneOf to -> Parser (MEventTypeOneOf to)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MEventTypeOneOf to
x
  | Bool
otherwise = Proxy '(to, ts)
-> Value -> Parser (MEventTypeOneOf (Fst '(to, ts)))
forall (a :: ([MEventType], [MEventType])).
ToParser a =>
Proxy a -> Value -> Parser (MEventTypeOneOf (Fst a))
toParser (forall {k} (t :: k). Proxy t
forall (t :: ([MEventType], [MEventType])). Proxy t
Proxy @'(to, ts)) Value
j


-- * Helpers

type family OneOf (x ∷ k) (xs ∷ [k]) ∷ Bool where
  OneOf _ '[] = 'False
  OneOf x (x ': _) = 'True
  OneOf x (y ': ys) = OneOf x ys

type family Fst (a ∷ (k1, k2)) ∷ k1 where
  Fst '(a, _) = a