{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall a msg. Key a msg -> Key a msg -> Bool
Eq, Int -> Key a msg -> ShowS
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
showList :: [Key a msg] -> ShowS
$cshowList :: forall a msg. [Key a msg] -> ShowS
show :: Key a msg -> String
$cshow :: forall a msg. Key a msg -> String
showsPrec :: Int -> Key a msg -> ShowS
$cshowsPrec :: forall a msg. Int -> Key a msg -> ShowS
Show, NonEmpty (Key a msg) -> Key a msg
Key a msg -> Key a msg -> 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
stimes :: forall b. Integral b => b -> Key a msg -> Key a msg
$cstimes :: forall a msg b. Integral b => b -> Key a msg -> Key a msg
sconcat :: NonEmpty (Key a msg) -> Key a msg
$csconcat :: forall a msg. NonEmpty (Key a msg) -> Key a msg
<> :: Key a msg -> Key a msg -> Key a msg
$c<> :: forall a msg. Key a msg -> 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
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
mconcat :: [Key a msg] -> Key a msg
$cmconcat :: forall a msg. [Key a msg] -> Key a msg
mappend :: Key a msg -> Key a msg -> Key a msg
$cmappend :: forall a msg. Key a msg -> Key a msg -> Key a msg
mempty :: Key a msg
$cmempty :: forall a msg. Key a msg
Monoid)

data Route

data Bind
    = Word Text
    | Any
    | Many
    deriving (Bind -> Bind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bind -> Bind -> Bool
$c/= :: Bind -> Bind -> Bool
== :: Bind -> Bind -> Bool
$c== :: Bind -> Bind -> Bool
Eq, Int -> Bind -> ShowS
[Bind] -> ShowS
Bind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bind] -> ShowS
$cshowList :: [Bind] -> ShowS
show :: Bind -> String
$cshow :: Bind -> String
showsPrec :: Int -> Bind -> ShowS
$cshowsPrec :: Int -> 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
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
List.map Bind -> Text
fromBind forall a b. (a -> b) -> a -> b
$ [Bind]
ns

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

-- | A specific word. Can be used to chain Routing keys or Binding keys
--
-- > key "messages" & word "new"
-- > -- matches "messages.new"
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) = forall a msg. [Bind] -> Key a msg
Key forall a b. (a -> b) -> a -> b
$ [Bind]
ws forall a. [a] -> [a] -> [a]
++ [Text -> Bind
toBind Text
w]

-- | Match any one word. Equivalent to `*`. Converts to a Binding key and can no longer be used to publish messaages
--
-- > key "messages" & any1
-- > -- matches "messages.new"
-- > -- matches "messages.update"
any1 :: Key a msg -> Key Bind msg
any1 :: forall a msg. Key a msg -> Key Bind msg
any1 (Key [Bind]
ws) = forall a msg. [Bind] -> Key a msg
Key ([Bind]
ws 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
--
-- > key "messages" & many
-- > -- matches "messages"
-- > -- matches "messages.new"
-- > -- matches "messages.1234.update"
many :: Key a msg -> Key Bind msg
many :: forall a msg. Key a msg -> Key Bind msg
many (Key [Bind]
ws) = forall a msg. [Bind] -> Key a msg
Key ([Bind]
ws forall a. [a] -> [a] -> [a]
++ [Bind
Many])

-- | 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) = 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 = ()