module Network.Mom.Stompl.Client.Factory (
        Con(..), mkUniqueConId,
        Sub(..), mkUniqueSubId,
        Tx (..), mkUniqueTxId,
        Rec(..), mkUniqueRecc, parseRec)
where

  ------------------------------------------------------------------------
  -- To-do:
  --   - Currently, we use running numbers to uniquely identify 
  --     subscription ids, receipts, transactions, etc.
  --   - A better approach is to use random numbers
  ------------------------------------------------------------------------

  import System.IO.Unsafe
  import Control.Concurrent
  import Data.Char (isDigit)

  ------------------------------------------------------------------------
  -- | Opaque Connection handle.
  --   Only valid within the action passed to /withConnection/. 
  ------------------------------------------------------------------------
  newtype Con = Con Int
    deriving (Con -> Con -> Bool
(Con -> Con -> Bool) -> (Con -> Con -> Bool) -> Eq Con
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Con -> Con -> Bool
$c/= :: Con -> Con -> Bool
== :: Con -> Con -> Bool
$c== :: Con -> Con -> Bool
Eq)

  instance Show Con where
    show :: Con -> String
show (Con Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i

  ------------------------------------------------------------------------
  -- Subscription Identifier
  ------------------------------------------------------------------------
  data Sub = Sub Int | NoSub
    deriving (Sub -> Sub -> Bool
(Sub -> Sub -> Bool) -> (Sub -> Sub -> Bool) -> Eq Sub
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sub -> Sub -> Bool
$c/= :: Sub -> Sub -> Bool
== :: Sub -> Sub -> Bool
$c== :: Sub -> Sub -> Bool
Eq)

  instance Show Sub where
    show :: Sub -> String
show (Sub Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
    show (Sub
NoSub) = String
""

  ------------------------------------------------------------------------
  -- Transaction Identifier
  ------------------------------------------------------------------------
  data Tx = Tx Int | NoTx
    deriving (Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c== :: Tx -> Tx -> Bool
Eq)

  instance Show Tx where
    show :: Tx -> String
show (Tx Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
    show (Tx
NoTx) = String
""

  ------------------------------------------------------------------------
  -- | This is a receipt.
  ------------------------------------------------------------------------
  data Rec = 
           -- | A valid receipt
           Rec Int 
           -- | No receipt was sent with this interaction.
           --   Receiving a 'NoRec' is not an error,
           --   but the result of an inconsistent - but harmless -
           --   use of /writeQWith/ on a queue that does not
           --   send receipts. An application should, of course,
           --   not try to wait for a 'NoRec'. It will never be confirmed.
           | NoRec
    deriving (Rec -> Rec -> Bool
(Rec -> Rec -> Bool) -> (Rec -> Rec -> Bool) -> Eq Rec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rec -> Rec -> Bool
$c/= :: Rec -> Rec -> Bool
== :: Rec -> Rec -> Bool
$c== :: Rec -> Rec -> Bool
Eq)

  instance Show Rec where
    show :: Rec -> String
show (Rec Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
    show  Rec
NoRec  = String
""

  parseRec :: String -> Maybe Rec
  parseRec :: String -> Maybe Rec
parseRec String
s = 
    if String -> Bool
numeric String
s then Rec -> Maybe Rec
forall a. a -> Maybe a
Just (Int -> Rec
Rec (Int -> Rec) -> Int -> Rec
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
s) else Maybe Rec
forall a. Maybe a
Nothing

  numeric :: String -> Bool
  numeric :: String -> Bool
numeric = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit

  ------------------------------------------------------------------------
  -- Source for unique connection identifiers
  ------------------------------------------------------------------------
  {-# NOINLINE conid #-}
  conid :: MVar Con
  conid :: MVar Con
conid = IO (MVar Con) -> MVar Con
forall a. IO a -> a
unsafePerformIO (IO (MVar Con) -> MVar Con) -> IO (MVar Con) -> MVar Con
forall a b. (a -> b) -> a -> b
$ Con -> IO (MVar Con)
forall a. a -> IO (MVar a)
newMVar (Int -> Con
Con Int
1)

  ------------------------------------------------------------------------
  -- Source for unique subscription identifiers
  ------------------------------------------------------------------------
  {-# NOINLINE subid #-}
  subid :: MVar Sub
  subid :: MVar Sub
subid = IO (MVar Sub) -> MVar Sub
forall a. IO a -> a
unsafePerformIO (IO (MVar Sub) -> MVar Sub) -> IO (MVar Sub) -> MVar Sub
forall a b. (a -> b) -> a -> b
$ Sub -> IO (MVar Sub)
forall a. a -> IO (MVar a)
newMVar (Int -> Sub
Sub Int
1)

  ------------------------------------------------------------------------
  -- Source for unique transaction identifiers
  ------------------------------------------------------------------------
  {-# NOINLINE txid #-}
  txid :: MVar Tx
  txid :: MVar Tx
txid = IO (MVar Tx) -> MVar Tx
forall a. IO a -> a
unsafePerformIO (IO (MVar Tx) -> MVar Tx) -> IO (MVar Tx) -> MVar Tx
forall a b. (a -> b) -> a -> b
$ Tx -> IO (MVar Tx)
forall a. a -> IO (MVar a)
newMVar (Int -> Tx
Tx Int
1)

  ------------------------------------------------------------------------
  -- Source for unique receipts
  ------------------------------------------------------------------------
  {-# NOINLINE recc #-}
  recc :: MVar Rec
  recc :: MVar Rec
recc = IO (MVar Rec) -> MVar Rec
forall a. IO a -> a
unsafePerformIO (IO (MVar Rec) -> MVar Rec) -> IO (MVar Rec) -> MVar Rec
forall a b. (a -> b) -> a -> b
$ Rec -> IO (MVar Rec)
forall a. a -> IO (MVar a)
newMVar (Int -> Rec
Rec Int
1)

  ------------------------------------------------------------------------
  -- Interfaces
  ------------------------------------------------------------------------
  mkUniqueConId :: IO Con
  mkUniqueConId :: IO Con
mkUniqueConId = MVar Con -> (Con -> Con) -> IO Con
forall a. MVar a -> (a -> a) -> IO a
mkUniqueId MVar Con
conid Con -> Con
incCon

  mkUniqueSubId :: IO Sub
  mkUniqueSubId :: IO Sub
mkUniqueSubId = MVar Sub -> (Sub -> Sub) -> IO Sub
forall a. MVar a -> (a -> a) -> IO a
mkUniqueId MVar Sub
subid Sub -> Sub
incSub

  mkUniqueTxId :: IO Tx
  mkUniqueTxId :: IO Tx
mkUniqueTxId = MVar Tx -> (Tx -> Tx) -> IO Tx
forall a. MVar a -> (a -> a) -> IO a
mkUniqueId MVar Tx
txid Tx -> Tx
incTx

  mkUniqueRecc :: IO Rec
  mkUniqueRecc :: IO Rec
mkUniqueRecc = MVar Rec -> (Rec -> Rec) -> IO Rec
forall a. MVar a -> (a -> a) -> IO a
mkUniqueId MVar Rec
recc Rec -> Rec
incRecc

  mkUniqueId :: MVar a -> (a -> a) -> IO a
  mkUniqueId :: MVar a -> (a -> a) -> IO a
mkUniqueId MVar a
v a -> a
f = MVar a -> (a -> IO (a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar a
v ((a -> IO (a, a)) -> IO a) -> (a -> IO (a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \a
x -> 
    let x' :: a
x' = a -> a
f a
x in (a, a) -> IO (a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x', a
x')

  incCon :: Con -> Con
  incCon :: Con -> Con
incCon (Con Int
n) = Int -> Con
Con (Int -> Int
incX Int
n)

  incSub :: Sub -> Sub
  incSub :: Sub -> Sub
incSub (Sub Int
n) = Int -> Sub
Sub (Int -> Int
incX Int
n)
  incSub Sub
NoSub   = Sub
NoSub

  incTx :: Tx -> Tx
  incTx :: Tx -> Tx
incTx (Tx Int
n) = Int -> Tx
Tx (Int -> Int
incX Int
n)
  incTx Tx
NoTx   = Tx
NoTx

  incRecc :: Rec -> Rec
  incRecc :: Rec -> Rec
incRecc (Rec Int
n) = Int -> Rec
Rec (Int -> Int
incX Int
n)
  incRecc (Rec
NoRec) = Rec
NoRec

  incX :: Int -> Int
  incX :: Int -> Int
incX Int
i = if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
99999999 then Int
1 else Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1