{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Network.AMQP.Worker.Key
    ( Key (..)
    , Bind (..)
    , Route
    , key
    , word
    , any1
    , many
    , keyText
    , fromBind
    , toBind
    , toBindKey
    , RequireRoute
    ) where

import Data.Kind (Constraint, Type)
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.TypeLits (ErrorMessage (..), TypeError)

-- | Messages are published with a specific identifier called a Routing key. Queues can use Binding Keys to control which messages are delivered to them.
--
-- Routing keys have no dynamic component and can be used to publish messages
--
-- > commentsKey :: Key Route Comment
-- > commentsKey = key "posts" & word "new"
--
-- Binding keys can contain wildcards, only used for matching messages
--
-- > commentsKey :: Key Bind Comment
-- > commentsKey = key "posts" & any1 & word "comments" & many
newtype Key a msg = Key [Bind]
    deriving (Key a msg -> Key a msg -> Bool
(Key a msg -> Key a msg -> Bool)
-> (Key a msg -> Key a msg -> Bool) -> Eq (Key a msg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a msg. Key a msg -> Key a msg -> Bool
$c== :: forall a msg. Key a msg -> Key a msg -> Bool
== :: Key a msg -> Key a msg -> Bool
$c/= :: forall a msg. Key a msg -> Key a msg -> Bool
/= :: Key a msg -> Key a msg -> Bool
Eq, Int -> Key a msg -> ShowS
[Key a msg] -> ShowS
Key a msg -> String
(Int -> Key a msg -> ShowS)
-> (Key a msg -> String)
-> ([Key a msg] -> ShowS)
-> Show (Key a msg)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a msg. Int -> Key a msg -> ShowS
forall a msg. [Key a msg] -> ShowS
forall a msg. Key a msg -> String
$cshowsPrec :: forall a msg. Int -> Key a msg -> ShowS
showsPrec :: Int -> Key a msg -> ShowS
$cshow :: forall a msg. Key a msg -> String
show :: Key a msg -> String
$cshowList :: forall a msg. [Key a msg] -> ShowS
showList :: [Key a msg] -> ShowS
Show, NonEmpty (Key a msg) -> Key a msg
Key a msg -> Key a msg -> Key a msg
(Key a msg -> Key a msg -> Key a msg)
-> (NonEmpty (Key a msg) -> Key a msg)
-> (forall b. Integral b => b -> Key a msg -> Key a msg)
-> Semigroup (Key a msg)
forall b. Integral b => b -> Key a msg -> Key a msg
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a msg. NonEmpty (Key a msg) -> Key a msg
forall a msg. Key a msg -> Key a msg -> Key a msg
forall a msg b. Integral b => b -> Key a msg -> Key a msg
$c<> :: forall a msg. Key a msg -> Key a msg -> Key a msg
<> :: Key a msg -> Key a msg -> Key a msg
$csconcat :: forall a msg. NonEmpty (Key a msg) -> Key a msg
sconcat :: NonEmpty (Key a msg) -> Key a msg
$cstimes :: forall a msg b. Integral b => b -> Key a msg -> Key a msg
stimes :: forall b. Integral b => b -> Key a msg -> Key a msg
Semigroup, Semigroup (Key a msg)
Key a msg
Semigroup (Key a msg) =>
Key a msg
-> (Key a msg -> Key a msg -> Key a msg)
-> ([Key a msg] -> Key a msg)
-> Monoid (Key a msg)
[Key a msg] -> Key a msg
Key a msg -> Key a msg -> Key a msg
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a msg. Semigroup (Key a msg)
forall a msg. Key a msg
forall a msg. [Key a msg] -> Key a msg
forall a msg. Key a msg -> Key a msg -> Key a msg
$cmempty :: forall a msg. Key a msg
mempty :: Key a msg
$cmappend :: forall a msg. Key a msg -> Key a msg -> Key a msg
mappend :: Key a msg -> Key a msg -> Key a msg
$cmconcat :: forall a msg. [Key a msg] -> Key a msg
mconcat :: [Key a msg] -> Key a msg
Monoid)

data Route

data Bind
    = Word Text
    | Any
    | Many
    deriving (Bind -> Bind -> Bool
(Bind -> Bind -> Bool) -> (Bind -> Bind -> Bool) -> Eq Bind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bind -> Bind -> Bool
== :: Bind -> Bind -> Bool
$c/= :: Bind -> Bind -> Bool
/= :: Bind -> Bind -> Bool
Eq, Int -> Bind -> ShowS
[Bind] -> ShowS
Bind -> String
(Int -> Bind -> ShowS)
-> (Bind -> String) -> ([Bind] -> ShowS) -> Show Bind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bind -> ShowS
showsPrec :: Int -> Bind -> ShowS
$cshow :: Bind -> String
show :: Bind -> String
$cshowList :: [Bind] -> ShowS
showList :: [Bind] -> ShowS
Show)

fromBind :: Bind -> Text
fromBind :: Bind -> Text
fromBind (Word Text
t) = Text
t
fromBind Bind
Any = Text
"*"
fromBind Bind
Many = Text
"#"

toBind :: Text -> Bind
toBind :: Text -> Bind
toBind = Text -> Bind
Word

keyText :: Key a msg -> Text
keyText :: forall a msg. Key a msg -> Text
keyText (Key [Bind]
ns) =
    Text -> [Text] -> Text
Text.intercalate Text
"." ([Text] -> Text) -> ([Bind] -> [Text]) -> [Bind] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bind -> Text) -> [Bind] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map Bind -> Text
fromBind ([Bind] -> Text) -> [Bind] -> Text
forall a b. (a -> b) -> a -> b
$ [Bind]
ns

-- | Match any one word. Equivalent to `*`. Converts to a Binding key and can no longer be used to publish messaages
any1 :: Key a msg -> Key Bind msg
any1 :: forall a msg. Key a msg -> Key Bind msg
any1 (Key [Bind]
ws) = [Bind] -> Key Bind msg
forall a msg. [Bind] -> Key a msg
Key ([Bind]
ws [Bind] -> [Bind] -> [Bind]
forall a. [a] -> [a] -> [a]
++ [Bind
Any])

-- | Match zero or more words. Equivalient to `#`. Converts to a Binding key and can no longer be used to publish messages
many :: Key a msg -> Key Bind msg
many :: forall a msg. Key a msg -> Key Bind msg
many (Key [Bind]
ws) = [Bind] -> Key Bind msg
forall a msg. [Bind] -> Key a msg
Key ([Bind]
ws [Bind] -> [Bind] -> [Bind]
forall a. [a] -> [a] -> [a]
++ [Bind
Many])

-- | A specific word. Can be used to chain Routing keys or Binding keys
word :: Text -> Key a msg -> Key a msg
word :: forall a msg. Text -> Key a msg -> Key a msg
word Text
w (Key [Bind]
ws) = [Bind] -> Key a msg
forall a msg. [Bind] -> Key a msg
Key ([Bind] -> Key a msg) -> [Bind] -> Key a msg
forall a b. (a -> b) -> a -> b
$ [Bind]
ws [Bind] -> [Bind] -> [Bind]
forall a. [a] -> [a] -> [a]
++ [Text -> Bind
toBind Text
w]

-- | Start a new routing key (can also be used for bindings)
key :: Text -> Key Route msg
key :: forall msg. Text -> Key Route msg
key Text
t = [Bind] -> Key Route msg
forall a msg. [Bind] -> Key a msg
Key [Text -> Bind
Word Text
t]

-- | We can convert Route Keys to Bind Keys safely, as they are usable for both publishing and binding
toBindKey :: Key a msg -> Key Bind msg
toBindKey :: forall a msg. Key a msg -> Key Bind msg
toBindKey (Key [Bind]
ws) = [Bind] -> Key Bind msg
forall a msg. [Bind] -> Key a msg
Key [Bind]
ws

-- | Custom error message when trying to publish to Binding keys
type family RequireRoute (a :: Type) :: Constraint where
    RequireRoute Bind =
        TypeError
            ( 'Text "Expected Routing Key but got Binding Key instead. Messages can be published only with keys that exclusivlely use `key` and `word`"
                :$$: 'Text "\n          key \"message\" & word \"new\" \n"
            )
    RequireRoute a = ()