module Database.MongoDB.Internal.Util where
import Control.Applicative (Applicative(..), (<$>))
import Control.Arrow (left)
import Control.Exception (assert)
import Control.Monad (liftM, liftM2)
import Data.Bits (Bits, (.|.))
import Data.Word (Word8)
import Network (PortID(..))
import Numeric (showHex)
import System.IO (Handle)
import System.IO.Error (mkIOError, eofErrorType)
import System.Random (newStdGen)
import System.Random.Shuffle (shuffle')
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import Control.Monad.Error (MonadError(..), ErrorT(..), Error(..))
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Bson
import Data.Text (Text)
import qualified Data.Text as T
#if !MIN_VERSION_network(2, 4, 1)
deriving instance Show PortID
deriving instance Eq PortID
#endif
deriving instance Ord PortID
class (MonadIO m, Applicative m, Functor m) => MonadIO' m
instance (MonadIO m, Applicative m, Functor m) => MonadIO' m
mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM cmp = mergesortM' cmp . map wrap
mergesortM' :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [a]
mergesortM' _ [] = return []
mergesortM' _ [xs] = return xs
mergesortM' cmp xss = mergesortM' cmp =<< (merge_pairsM cmp xss)
merge_pairsM :: Monad m => (a -> a -> m Ordering) -> [[a]] -> m [[a]]
merge_pairsM _ [] = return []
merge_pairsM _ [xs] = return [xs]
merge_pairsM cmp (xs:ys:xss) = liftM2 (:) (mergeM cmp xs ys) (merge_pairsM cmp xss)
mergeM :: Monad m => (a -> a -> m Ordering) -> [a] -> [a] -> m [a]
mergeM _ [] ys = return ys
mergeM _ xs [] = return xs
mergeM cmp (x:xs) (y:ys)
= do
c <- x `cmp` y
case c of
GT -> liftM (y:) (mergeM cmp (x:xs) ys)
_ -> liftM (x:) (mergeM cmp xs (y:ys))
wrap :: a -> [a]
wrap x = [x]
shuffle :: [a] -> IO [a]
shuffle list = shuffle' list (length list) <$> newStdGen
loop :: (Functor m, Monad m) => m (Maybe a) -> m [a]
loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act)
untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b
untilSuccess = untilSuccess' (strMsg "empty untilSuccess")
untilSuccess' :: (MonadError e m) => e -> (a -> m b) -> [a] -> m b
untilSuccess' e _ [] = throwError e
untilSuccess' _ f (x : xs) = catchError (f x) (\e -> untilSuccess' e f xs)
whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
whenJust mVal act = maybe (return ()) act mVal
liftIOE :: (MonadIO m) => (e -> e') -> ErrorT e IO a -> ErrorT e' m a
liftIOE f = ErrorT . liftIO . fmap (left f) . runErrorT
runIOE :: ErrorT IOError IO a -> IO a
runIOE (ErrorT action) = action >>= either ioError return
updateAssocs :: (Eq k) => k -> v -> [(k, v)] -> [(k, v)]
updateAssocs key valu assocs = case back of [] -> (key, valu) : front; _ : back' -> front ++ (key, valu) : back'
where (front, back) = break ((key ==) . fst) assocs
bitOr :: (Num a, Bits a) => [a] -> a
bitOr = foldl (.|.) 0
(<.>) :: Text -> Text -> Text
a <.> b = T.append a (T.cons '.' b)
true1 :: Label -> Document -> Bool
true1 k doc = case valueAt k doc of
Bool b -> b
Float n -> n == 1
Int32 n -> n == 1
Int64 n -> n == 1
_ -> error $ "expected " ++ show k ++ " to be Num or Bool in " ++ show doc
hGetN :: Handle -> Int -> IO L.ByteString
hGetN h n = assert (n >= 0) $ do
bytes <- L.hGet h n
let x = fromEnum $ L.length bytes
if x >= n then return bytes
else if x == 0 then ioError (mkIOError eofErrorType "hGetN" (Just h) Nothing)
else L.append bytes <$> hGetN h (n x)
byteStringHex :: S.ByteString -> String
byteStringHex = concatMap byteHex . S.unpack
byteHex :: Word8 -> String
byteHex b = (if b < 16 then ('0' :) else id) (showHex b "")