{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Network.AMQP.Worker.Key
    ( Key (..)
    , Binding (..)
    , BindingWord
    , Routing
    , key
    , word
    , star
    , hash
    , keyText
    , KeySegment (..)
    , bindingKey
    ) where

import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text

-- | Keys describe routing and binding info for a message
newtype Key a msg = Key [a]
    deriving (Key a msg -> Key a msg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a msg. Eq a => Key a msg -> Key a msg -> Bool
/= :: Key a msg -> Key a msg -> Bool
$c/= :: forall a msg. Eq a => Key a msg -> Key a msg -> Bool
== :: Key a msg -> Key a msg -> Bool
$c== :: forall a msg. Eq a => 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. Show a => Int -> Key a msg -> ShowS
forall a msg. Show a => [Key a msg] -> ShowS
forall a msg. Show a => Key a msg -> String
showList :: [Key a msg] -> ShowS
$cshowList :: forall a msg. Show a => [Key a msg] -> ShowS
show :: Key a msg -> String
$cshow :: forall a msg. Show a => Key a msg -> String
showsPrec :: Int -> Key a msg -> ShowS
$cshowsPrec :: forall a msg. Show a => 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)

-- | Every message is sent with a specific routing key
--
-- > newCommentKey :: Key Routing Comment
-- > newCommentKey = key "posts" & word "1" & word "comments" & word "new"
newtype Routing = Routing Text
    deriving (Routing -> Routing -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Routing -> Routing -> Bool
$c/= :: Routing -> Routing -> Bool
== :: Routing -> Routing -> Bool
$c== :: Routing -> Routing -> Bool
Eq, Int -> Routing -> ShowS
[Routing] -> ShowS
Routing -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Routing] -> ShowS
$cshowList :: [Routing] -> ShowS
show :: Routing -> String
$cshow :: Routing -> String
showsPrec :: Int -> Routing -> ShowS
$cshowsPrec :: Int -> Routing -> ShowS
Show)

instance KeySegment Routing where
    toText :: Routing -> Text
toText (Routing Text
s) = Text
s
    fromText :: Text -> Routing
fromText = Text -> Routing
Routing
    toBind :: Routing -> Binding
toBind (Routing Text
s) = Text -> Binding
Word Text
s

-- | A dynamic binding address for topic queues
--
-- > commentsKey :: Key Binding Comment
-- > commentsKey = key "posts" & star & word "comments" & hash
data Binding
    = Word BindingWord
    | Star
    | Hash
    deriving (Binding -> Binding -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c== :: Binding -> Binding -> Bool
Eq, Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Binding] -> ShowS
$cshowList :: [Binding] -> ShowS
show :: Binding -> String
$cshow :: Binding -> String
showsPrec :: Int -> Binding -> ShowS
$cshowsPrec :: Int -> Binding -> ShowS
Show)

instance KeySegment Binding where
    toText :: Binding -> Text
toText (Word Text
t) = Text
t
    toText Binding
Star = Text
"*"
    toText Binding
Hash = Text
"#"
    fromText :: Text -> Binding
fromText = Text -> Binding
Word
    toBind :: Binding -> Binding
toBind = forall a. a -> a
id

class KeySegment a where
    toText :: a -> Text
    fromText :: Text -> a
    toBind :: a -> Binding

keyText :: KeySegment a => Key a msg -> Text
keyText :: forall a msg. KeySegment a => Key a msg -> Text
keyText (Key [a]
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 forall a. KeySegment a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ [a]
ns

-- | Convert any key to a binding key
bindingKey :: KeySegment a => Key a msg -> Key Binding msg
bindingKey :: forall a msg. KeySegment a => Key a msg -> Key Binding msg
bindingKey (Key [a]
rs) = forall a msg. [a] -> Key a msg
Key (forall a b. (a -> b) -> [a] -> [b]
map forall a. KeySegment a => a -> Binding
toBind [a]
rs)

-- | Match any one word
star :: KeySegment a => Key a msg -> Key Binding msg
star :: forall a msg. KeySegment a => Key a msg -> Key Binding msg
star (Key [a]
ws) = forall a msg. [a] -> Key a msg
Key (forall a b. (a -> b) -> [a] -> [b]
map forall a. KeySegment a => a -> Binding
toBind [a]
ws forall a. [a] -> [a] -> [a]
++ [Binding
Star])

-- | Match any words
hash :: KeySegment a => Key a msg -> Key Binding msg
hash :: forall a msg. KeySegment a => Key a msg -> Key Binding msg
hash (Key [a]
ws) = forall a msg. [a] -> Key a msg
Key (forall a b. (a -> b) -> [a] -> [b]
map forall a. KeySegment a => a -> Binding
toBind [a]
ws forall a. [a] -> [a] -> [a]
++ [Binding
Hash])

-- | Match a specific word
word :: KeySegment a => Text -> Key a msg -> Key a msg
word :: forall a msg. KeySegment a => Text -> Key a msg -> Key a msg
word Text
w (Key [a]
ws) = forall a msg. [a] -> Key a msg
Key forall a b. (a -> b) -> a -> b
$ [a]
ws forall a. [a] -> [a] -> [a]
++ [forall a. KeySegment a => Text -> a
fromText Text
w]

-- | Create a new key
key :: Text -> Key Routing msg
key :: forall msg. Text -> Key Routing msg
key Text
t = forall a msg. [a] -> Key a msg
Key [Text -> Routing
Routing Text
t]

type BindingWord = Text