{-# 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
mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> m [a]
mergesortM a -> a -> m Ordering
cmp = forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
cmp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> [a]
wrap
mergesortM' :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
mergesortM' a -> a -> m Ordering
_ [[a]
xs] = forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
mergesortM' a -> a -> m Ordering
cmp [[a]]
xss = forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' a -> a -> m Ordering
cmp forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (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 :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM a -> a -> m Ordering
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
merge_pairsM a -> a -> m Ordering
_ [[a]
xs] = forall (m :: * -> *) a. Monad m => a -> m a
return [[a]
xs]
merge_pairsM a -> a -> m Ordering
cmp ([a]
xs:[a]
ys:[[a]]
xss) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp [a]
xs [a]
ys) (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 :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
_ [] [a]
ys = forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ys
mergeM a -> a -> m Ordering
_ [a]
xs [] = 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 -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
yforall a. a -> [a] -> [a]
:) (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp (a
xforall a. a -> [a] -> [a]
:[a]
xs) [a]
ys)
Ordering
_ -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (a
xforall a. a -> [a] -> [a]
:) (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM a -> a -> m Ordering
cmp [a]
xs (a
yforall a. a -> [a] -> [a]
:[a]
ys))
wrap :: a -> [a]
wrap :: forall a. a -> [a]
wrap a
x = [a
x]
shuffle :: [a] -> IO [a]
shuffle :: forall a. [a] -> IO [a]
shuffle [a]
list = forall gen a. RandomGen gen => [a] -> Int -> gen -> [a]
shuffle' [a]
list (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
list) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
loop :: Monad m => m (Maybe a) -> m [a]
loop :: forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
loop m (Maybe a)
act = m (Maybe a)
act forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return []) (\a
a -> (a
a forall a. a -> [a] -> [a]
:) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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
untilSuccess :: forall e (m :: * -> *) a b.
MonadError e m =>
(a -> m b) -> [a] -> m b
untilSuccess = forall e (m :: * -> *) a b.
MonadError e m =>
e -> (a -> m b) -> [a] -> m b
untilSuccess' (forall a. HasCallStack => [Char] -> a
error [Char]
"empty untilSuccess")
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
untilSuccess' :: forall e (m :: * -> *) a b.
MonadError e m =>
e -> (a -> m b) -> [a] -> m b
untilSuccess' e
e a -> 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) = forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (a -> m b
f a
x) (\e
e -> 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 :: forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe a
mVal a -> m ()
act = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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
liftIOE :: forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE e -> e'
f = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f)
updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]
updateAssocs :: forall k v. Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateAssocs k
key v
valu [(k, v)]
assocs = case [(k, v)]
back of [] -> (k
key, v
valu) forall a. a -> [a] -> [a]
: [(k, v)]
front; (k, v)
_ : [(k, v)]
back' -> [(k, v)]
front forall a. [a] -> [a] -> [a]
++ (k
key, v
valu) forall a. a -> [a] -> [a]
: [(k, v)]
back'
where ([(k, v)]
front, [(k, v)]
back) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((k
key forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(k, v)]
assocs
bitOr :: (Num a, Bits a) => [a] -> a
bitOr :: forall a. (Num a, Bits a) => [a] -> a
bitOr = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Bits a => a -> a -> a
(.|.) a
0
(<.>) :: Text -> Text -> Text
Label
a <.> :: Label -> Label -> Label
<.> Label
b = Label -> Label -> Label
T.append Label
a (Char -> Label -> Label
T.cons Char
'.' Label
b)
true1 :: Label -> Document -> Bool
true1 :: Label -> Document -> Bool
true1 Label
k Document
doc = case Label -> Document -> Value
valueAt Label
k Document
doc of
Bool Bool
b -> Bool
b
Float Double
n -> Double
n forall a. Eq a => a -> a -> Bool
== Double
1
Int32 Int32
n -> Int32
n forall a. Eq a => a -> a -> Bool
== Int32
1
Int64 Int64
n -> Int64
n forall a. Eq a => a -> a -> Bool
== Int64
1
Value
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Label
k forall a. [a] -> [a] -> [a]
++ [Char]
" to be Num or Bool in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Document
doc
byteStringHex :: S.ByteString -> String
byteStringHex :: ByteString -> [Char]
byteStringHex = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> [Char]
byteHex forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
S.unpack
byteHex :: Word8 -> String
byteHex :: Word8 -> [Char]
byteHex Word8
b = (if Word8
b forall a. Ord a => a -> a -> Bool
< Word8
16 then (Char
'0' forall a. a -> [a] -> [a]
:) else forall a. a -> a
id) (forall a. (Integral a, Show a) => a -> [Char] -> [Char]
showHex Word8
b [Char]
"")