-- | Miscellaneous general functions

{-# LANGUAGE FlexibleInstances, UndecidableInstances, StandaloneDeriving #-}
{-# LANGUAGE CPP #-}

module Database.MongoDB.Internal.Util where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (handle, throwIO, Exception)
import Control.Monad (liftM, liftM2)
import Data.Bits (Bits, (.|.))
import Data.Word (Word8)
import Numeric (showHex)
import System.Random (newStdGen)
import System.Random.Shuffle (shuffle')

import qualified Data.ByteString as S

import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Bson
import Data.Text (Text)

import qualified Data.Text as T

-- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude
mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM :: (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM a -> a -> m Ordering
cmp = (a -> a -> m Ordering) -> [[a]] -> m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
cmp ([[a]] -> m [a]) -> ([a] -> [[a]]) -> [a] -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [a]
forall a. a -> [a]
wrap

mergesortM' :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' :: (a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
_  [] = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mergesortM' a -> a -> m Ordering
_  [[a]
xs] = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
mergesortM' a -> a -> m Ordering
cmp [[a]]
xss = (a -> a -> m Ordering) -> [[a]] -> m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
cmp ([[a]] -> m [a]) -> m [[a]] -> m [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((a -> a -> m Ordering) -> [[a]] -> m [[a]]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM a -> a -> m Ordering
cmp [[a]]
xss)

merge_pairsM :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM :: (a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM a -> a -> m Ordering
_   [] = [[a]] -> m [[a]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
merge_pairsM a -> a -> m Ordering
_   [[a]
xs] = [[a]] -> m [[a]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[a]
xs]
merge_pairsM a -> a -> m Ordering
cmp ([a]
xs:[a]
ys:[[a]]
xss) = ([a] -> [[a]] -> [[a]]) -> m [a] -> m [[a]] -> m [[a]]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) ((a -> a -> m Ordering) -> [a] -> [a] -> m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp [a]
xs [a]
ys) ((a -> a -> m Ordering) -> [[a]] -> m [[a]]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM a -> a -> m Ordering
cmp [[a]]
xss)

mergeM :: Monad m => (a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM :: (a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
_   [] [a]
ys = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ys
mergeM a -> a -> m Ordering
_   [a]
xs [] = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
mergeM a -> a -> m Ordering
cmp (a
x:[a]
xs) (a
y:[a]
ys)
 = do
     Ordering
c <- a
x a -> a -> m Ordering
`cmp` a
y
     case Ordering
c of
        Ordering
GT -> ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((a -> a -> m Ordering) -> [a] -> [a] -> m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)   [a]
ys)
        Ordering
_  -> ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((a -> a -> m Ordering) -> [a] -> [a] -> m [a]
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp    [a]
xs (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys))

wrap :: a -> [a]
wrap :: a -> [a]
wrap a
x = [a
x]

shuffle :: [a] -> IO [a]
-- ^ Randomly shuffle items in list
shuffle :: [a] -> IO [a]
shuffle [a]
list = [a] -> Int -> StdGen -> [a]
forall gen a. RandomGen gen => [a] -> Int -> gen -> [a]
shuffle' [a]
list ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list) (StdGen -> [a]) -> IO StdGen -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen

loop :: Monad m => m (Maybe a) -> m [a]
-- ^ Repeatedy execute action, collecting results, until it returns Nothing
loop :: m (Maybe a) -> m [a]
loop m (Maybe a)
act = m (Maybe a)
act m (Maybe a) -> (Maybe a -> m [a]) -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m [a] -> (a -> m [a]) -> Maybe a -> m [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (\a
a -> (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` m (Maybe a) -> m [a]
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
loop m (Maybe a)
act)

untilSuccess :: (MonadError e m) => (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty.
untilSuccess :: (a -> m b) -> [a] -> m b
untilSuccess = e -> (a -> m b) -> [a] -> m b
forall e (m :: * -> *) a b.
MonadError e m =>
e -> (a -> m b) -> [a] -> m b
untilSuccess' ([Char] -> e
forall a. HasCallStack => [Char] -> a
error [Char]
"empty untilSuccess")
-- Use 'error' copying behavior in removed 'Control.Monad.Error.Error' instance:
-- instance Error Failure where strMsg = error
-- 'fail' is treated the same as a programming 'error'. In other words, don't use it.

untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
-- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw given error if list is empty
untilSuccess' :: e -> (a -> m b) -> [a] -> m b
untilSuccess' e
e a -> m b
_ [] = e -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
untilSuccess' e
_ a -> m b
f (a
x : [a]
xs) = m b -> (e -> m b) -> m b
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (a -> m b
f a
x) (\e
e -> e -> (a -> m b) -> [a] -> m b
forall e (m :: * -> *) a b.
MonadError e m =>
e -> (a -> m b) -> [a] -> m b
untilSuccess' e
e a -> m b
f [a]
xs)

whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
whenJust :: Maybe a -> (a -> m ()) -> m ()
whenJust Maybe a
mVal a -> m ()
act = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
act Maybe a
mVal

liftIOE :: (MonadIO m, Exception e, Exception e') => (e -> e') -> IO a -> m a
-- ^ lift IOE monad to ErrorT monad over some MonadIO m
liftIOE :: (e -> e') -> IO a -> m a
liftIOE e -> e'
f = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (IO a -> IO a) -> IO a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (e' -> IO a
forall e a. Exception e => e -> IO a
throwIO (e' -> IO a) -> (e -> e') -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f)

updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]
-- ^ Change or insert value of key in association list
updateAssocs :: k -> v -> [(k, v)] -> [(k, v)]
updateAssocs k
key v
valu [(k, v)]
assocs = case [(k, v)]
back of [] -> (k
key, v
valu) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
front; (k, v)
_ : [(k, v)]
back' -> [(k, v)]
front [(k, v)] -> [(k, v)] -> [(k, v)]
forall a. [a] -> [a] -> [a]
++ (k
key, v
valu) (k, v) -> [(k, v)] -> [(k, v)]
forall a. a -> [a] -> [a]
: [(k, v)]
back'
    where ([(k, v)]
front, [(k, v)]
back) = ((k, v) -> Bool) -> [(k, v)] -> ([(k, v)], [(k, v)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((k
key k -> k -> Bool
forall a. Eq a => a -> a -> Bool
==) (k -> Bool) -> ((k, v) -> k) -> (k, v) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, v) -> k
forall a b. (a, b) -> a
fst) [(k, v)]
assocs

bitOr :: (Num a, Bits a) => [a] -> a
-- ^ bit-or all numbers together
bitOr :: [a] -> a
bitOr = (a -> a -> a) -> a -> [a] -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> a -> a
forall a. Bits a => a -> a -> a
(.|.) a
0

(<.>) :: Text -> Text -> Text
-- ^ Concat first and second together with period in between. Eg. @\"hello\" \<.\> \"world\" = \"hello.world\"@
Text
a <.> :: Text -> Text -> Text
<.> Text
b = Text -> Text -> Text
T.append Text
a (Char -> Text -> Text
T.cons Char
'.' Text
b)

true1 :: Label -> Document -> Bool
-- ^ Is field's value a 1 or True (MongoDB use both Int and Bools for truth values). Error if field not in document or field not a Num or Bool.
true1 :: Text -> Document -> Bool
true1 Text
k Document
doc = case Text -> Document -> Value
valueAt Text
k Document
doc of
    Bool Bool
b -> Bool
b
    Float Double
n -> Double
n Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1
    Int32 Int32
n -> Int32
n Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
1
    Int64 Int64
n -> Int64
n Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
1
    Value
_ -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error ([Char] -> Bool) -> [Char] -> Bool
forall a b. (a -> b) -> a -> b
$ [Char]
"expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to be Num or Bool in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Document -> [Char]
forall a. Show a => a -> [Char]
show Document
doc

byteStringHex :: S.ByteString -> String
-- ^ Hexadecimal string representation of a byte string. Each byte yields two hexadecimal characters.
byteStringHex :: ByteString -> [Char]
byteStringHex = (Word8 -> [Char]) -> [Word8] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> [Char]
byteHex ([Word8] -> [Char])
-> (ByteString -> [Word8]) -> ByteString -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack

byteHex :: Word8 -> String
-- ^ Two char hexadecimal representation of byte
byteHex :: Word8 -> [Char]
byteHex Word8
b = (if Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16 then (Char
'0' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) else [Char] -> [Char]
forall a. a -> a
id) (Word8 -> [Char] -> [Char]
forall a. (Integral a, Show a) => a -> [Char] -> [Char]
showHex Word8
b [Char]
"")