{-# LANGUAGE CPP           #-}
# LANGUAGE DataKinds      #
# LANGUAGE PolyKinds      #
{-# LANGUAGE RankNTypes    #-}
# LANGUAGE TypeFamilies   #
# LANGUAGE TypeOperators #

module Pos.Util.Util
       (
       -- * Cool stuff
         type (~>)
       -- * Exceptions/errors
       , maybeThrow
       , eitherToThrow
       , liftEither
       , leftToPanic
       , toAesonError
       , aesonError
       , toCborError
       , cborError
       , toTemplateHaskellError
       , templateHaskellError
       , toParsecError
       , parsecError
       , toCerealError
       , cerealError
       , DisallowException

       -- * Ether
       , ether
       , Ether.TaggedTrans
       , HasLens(..)
       , HasLens'
       , lensOf'
       , lensOfProxy

       -- * Lifting monads
       , PowerLift(..)

  * 
       , MinMax(..)
       , _MinMax
       , mkMinMax
       , minMaxOf

  * 
       , parseJSONWithRead

  * NonEmpty
       , neZipWith3
       , neZipWith4
       , spanSafe
       , takeLastNE

       -- * Logging helpers
       , buildListBounds
       , multilineBounds
       , logException
       , bracketWithLogging

       -- * Misc
       , mconcatPair
       , microsecondsToUTC
       , Sign (..)
       , getKeys
       , sortWithMDesc
       , dumpSplices
       , histogram
       , median
       , (<//>)
       , divRoundUp
       , sleep
       , intords

       , tMeasureLog
       , tMeasureIO
       , timed

       , realTime
       ) where

import           Universum

import qualified Codec.CBOR.Decoding as CBOR
import           Control.Concurrent (threadDelay)
import qualified Control.Exception.Safe as E
import           Control.Lens (Getting, Iso', coerced, foldMapOf, ( # ))
import           Control.Monad.Except (MonadError, throwError)
import           Control.Monad.Trans.Class (MonadTrans)
import           Data.Aeson (FromJSON (..))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import           Data.HashSet (fromMap)
import           Data.List (span, zipWith3, zipWith4)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import           Data.Ratio ((%))
import qualified Data.Semigroup as Smg
import qualified Data.Serialize as Cereal
import           Data.Text (pack)
import           Data.Text.Lazy.Builder (fromText)
import           Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime,
                     getCurrentTime)
import           Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
import           Data.Time.Units (Microsecond, fromMicroseconds, toMicroseconds)
import qualified Ether
import           Ether.Internal (HasLens (..))
import qualified Formatting as F
import           GHC.TypeLits (ErrorMessage (..))
import qualified Language.Haskell.TH as TH
import           Pos.Util.Wlog (LoggerName, WithLogger, logDebug, logError,
                     logInfo, usingLoggerName)
import qualified Prelude
import           Serokell.Util (listJson)
import           Serokell.Util.Exceptions ()
import qualified Text.Megaparsec as P

----------------------------------------------------------------------------
-- Cool stuff
----------------------------------------------------------------------------

type f ~> g = forall x. f x -> g x

----------------------------------------------------------------------------
-- Exceptions/errors
----------------------------------------------------------------------------

maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow e = maybe (throwM e) pure

  | Throw exception ( in ' MonadThrow ' ) or return result depending on
-- what is stored in 'Either'
eitherToThrow
    :: (MonadThrow m, Exception e)
    => Either e a -> m a
eitherToThrow = either throwM pure

  | ' liftEither ' from mtl-2.2.2 .
  TODO : use mtl version after we start using 2.2.2 .
liftEither
    :: (MonadError e m)
    => Either e a -> m a
liftEither = either throwError pure

-- | Partial function which calls 'error' with meaningful message if
-- given 'Left' and returns some value if given 'Right'.
-- Intended usage is when you're sure that value must be right.
leftToPanic :: Buildable a => Text -> Either a b -> b
leftToPanic msgPrefix = either (error . mappend msgPrefix . pretty) identity

  | This unexported helper is used to define conversions to ' MonadFail '
-- forced on us by external APIs. I also used underscores in its name, so don't
-- you think about exporting it -- define a specialized helper instead.
--
  This must be the only place in our codebase where we allow ' MonadFail ' .
external_api_fail :: MonadFail m => Either Text ~> m
external_api_fail = either (fail . toString) return

-- | Convert an 'Either'-encoded failure to an 'aeson' parser failure. The
  return monad is intentionally specialized because we avoid ' MonadFail ' .
toAesonError :: Either Text ~> A.Parser
toAesonError = external_api_fail

aesonError :: Text -> A.Parser a
aesonError = toAesonError . Left

-- | Convert an 'Either'-encoded failure to a 'cborg' decoder failure. The
  return monad is intentionally specialized because we avoid ' MonadFail ' .
toCborError :: Either Text ~> CBOR.Decoder s
toCborError = external_api_fail

cborError :: Text -> CBOR.Decoder s a
cborError = toCborError . Left

-- | Convert an 'Either'-encoded failure to a 'TH' Q-monad failure. The
  return monad is intentionally specialized because we avoid ' MonadFail ' .
toTemplateHaskellError :: Either Text ~> TH.Q
toTemplateHaskellError = external_api_fail

templateHaskellError :: Text -> TH.Q a
templateHaskellError = toTemplateHaskellError . Left

-- | Convert an 'Either'-encoded failure to a 'cereal' failure. The
  return monad is intentionally specialized because we avoid ' MonadFail ' .
toCerealError :: Either Text ~> Cereal.Get
toCerealError = external_api_fail

cerealError :: Text -> Cereal.Get a
cerealError = toCerealError . Left

-- | Convert an 'Either'-encoded failure to a 'megaparsec' failure. The
  return monad is intentionally specialized because we avoid ' MonadFail ' .
toParsecError :: P.Stream s => Either Text ~> P.ParsecT e s m
toParsecError = external_api_fail

parsecError :: P.Stream s => Text -> P.ParsecT e s m a
parsecError = toParsecError . Left

type family DisallowException t :: ErrorMessage where
    DisallowException t =
             'ShowType t ':<>:
             'Text " intentionally doesn't have an 'Exception' instance."
        ':$$: 'Text
             "This type shouldn't be thrown as a runtime exception."
        ':$$: 'Text
             "If you want to throw it, consider defining your own exception \
             \type with a constructor storing a value of this type."
        ':$$: 'Text
             "See the exception handling guidelines for more details."
        ':$$: 'Text ""

----------------------------------------------------------------------------
-- Ether
----------------------------------------------------------------------------

-- | Make a Reader or State computation work in an Ether transformer. Useful
-- to make lenses work with Ether.
ether :: trans m a -> Ether.TaggedTrans tag trans m a
ether = Ether.TaggedTrans

-- | Convenient shortcut for 'HasLens' constraint when lens is to the
-- same type as the tag.
type HasLens' s a = HasLens a s a

-- | Version of 'lensOf' which is used when lens is to the same type
-- as the tag.
lensOf' :: forall a s. HasLens' s a => Lens' s a
lensOf' = lensOf @a

-- | Version of 'lensOf' which uses proxy.
lensOfProxy :: forall proxy tag a b. HasLens tag a b => proxy tag -> Lens' a b
lensOfProxy _ = lensOf @tag

----------------------------------------------------------------------------
-- PowerLift
----------------------------------------------------------------------------

class PowerLift m n where
    powerLift :: m a -> n a

instance {-# OVERLAPPING #-} PowerLift m m where
    powerLift = identity

instance (MonadTrans t, PowerLift m n, Monad n) => PowerLift m (t n) where
  powerLift = lift . powerLift @m @n

----------------------------------------------------------------------------
  MinMax
----------------------------------------------------------------------------

newtype MinMax a = MinMax (Smg.Option (Smg.Min a, Smg.Max a))
#if MIN_VERSION_base(4,9,0)
  deriving (Smg.Semigroup, Monoid)
#else
  deriving (Monoid)
#endif

_MinMax :: Iso' (MinMax a) (Maybe (a, a))
_MinMax = coerced

mkMinMax :: a -> MinMax a
mkMinMax a = _MinMax # Just (a, a)

minMaxOf :: Getting (MinMax a) s a -> s -> Maybe (a, a)
minMaxOf l = view _MinMax . foldMapOf l mkMinMax

----------------------------------------------------------------------------
-- Aeson
----------------------------------------------------------------------------

-- | Parse a value represented as a 'show'-ed string in JSON.
parseJSONWithRead :: Read a => A.Value -> A.Parser a
parseJSONWithRead =
    toAesonError . readEither @String <=<
    parseJSON

----------------------------------------------------------------------------
  NonEmpty
----------------------------------------------------------------------------

neZipWith3 :: (x -> y -> z -> q) -> NonEmpty x -> NonEmpty y -> NonEmpty z -> NonEmpty q
neZipWith3 f (x :| xs) (y :| ys) (z :| zs) = f x y z :| zipWith3 f xs ys zs

neZipWith4 ::
       (x -> y -> i -> z -> q)
    -> NonEmpty x
    -> NonEmpty y
    -> NonEmpty i
    -> NonEmpty z
    -> NonEmpty q
neZipWith4 f (x :| xs) (y :| ys) (i :| is) (z :| zs) = f x y i z :| zipWith4 f xs ys is zs

-- | Makes a span on the list, considering tail only. Predicate has
  list head as first argument . Used to take non - null prefix that
  depends on the first element .
spanSafe :: (a -> a -> Bool) -> NonEmpty a -> (NonEmpty a, [a])
spanSafe p (x:|xs) = let (a,b) = span (p x) xs in (x:|a,b)

-- | Takes last N elements of the list
takeLastNE :: Int -> NonEmpty a -> [a]
takeLastNE n = reverse . NE.take n . NE.reverse

----------------------------------------------------------------------------
-- Logging helpers
----------------------------------------------------------------------------

  | Formats two values as first and last elements of a list
buildListBounds :: Buildable a => F.Format r (NonEmpty a -> r)
buildListBounds = F.later formatList
  where
    formatList (x:|[]) = F.bprint ("[" F.% F.build F.% "]") x
    formatList xs = F.bprint ("[" F.% F.build F.% ".." F.% F.build F.% "]")
        (NE.head xs)
        (NE.last xs)

-- | Formats only start and the end of the list according to the maximum size
multilineBounds :: Buildable a => Int -> F.Format r (NonEmpty a -> r)
multilineBounds maxSize = F.later formatList
 where
   formatList xs = if length xs <= maxSize'
       then F.bprint listJson xs
       else F.bprint
          ("First " F.% F.int F.% ": " F.% listJson F.% "\nLast " F.% F.int F.% ": " F.% listJson)
          half
          (NE.take half xs)
          remaining
          (takeLastNE remaining xs)
  splitting list into two with maximum size below 2 does n't make sense
   half = maxSize' `div` 2
   remaining = maxSize' - half

-- | Catch and log an exception, then rethrow it
logException :: LoggerName -> IO a -> IO a
logException name = E.handleAsync (\e -> handler e >> E.throw e)
  where
    handler :: E.SomeException -> IO ()
    handler exc = do
        let message = "logException: " <> pretty exc
        usingLoggerName name (logError message) `E.catchAny` \loggingExc -> do
            putStrLn message
            putStrLn $
                "logException failed to use logging: " <> pretty loggingExc

-- | 'bracket' which logs given message after acquiring the resource
-- and before calling the callback with 'Info' severity.
bracketWithLogging ::
       (MonadMask m, WithLogger m)
    => Text
    -> m a
    -> (a -> m b)
    -> (a -> m c)
    -> m c
bracketWithLogging msg acquire release = bracket acquire release . addLogging
  where
    addLogging callback resource = do
        logInfo $ "<bracketWithLogging:before> " <> msg
        callback resource <*
            logInfo ("<bracketWithLogging:after> " <> msg)

----------------------------------------------------------------------------
-- Misc
----------------------------------------------------------------------------

  | Specialized version of ' mconcat ' ( or ' Data.Foldable.fold ' )
-- for restricting type to list of pairs.
mconcatPair :: (Monoid a, Monoid b) => [(a, b)] -> (a, b)
mconcatPair = mconcat

microsecondsToUTC :: Microsecond -> UTCTime
microsecondsToUTC = posixSecondsToUTCTime . fromRational . (% 1000000) . toMicroseconds

data Sign = Plus | Minus

  | Create HashSet from HashMap 's keys
getKeys :: HashMap k v -> HashSet k
getKeys = fromMap . void

-- | Use some monadic action to evaluate priority of value and sort a
-- list of values based on this priority. The order is descending
-- because I need it.
sortWithMDesc :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
sortWithMDesc f = fmap (map fst . sortWith (Down . snd)) . mapM f'
  where
    f' x = (x, ) <$> f x

  | Concatenates two url parts using regular slash ' / ' .
-- E.g. @"./dir/" <//> "/file" = "./dir/file"@.
(<//>) :: String -> String -> String
(<//>) lhs rhs = lhs' ++ "/" ++ rhs'
  where
    isSlash = (== '/')
    lhs' = reverse $ dropWhile isSlash $ reverse lhs
    rhs' = dropWhile isSlash rhs

-- | To be used with paging of any kind.
  The pages should contain N elements ( we use 10 by default ):
-- - 1  - 10
-- - 11 - 20
-- - 21 - 30
divRoundUp :: Integral a => a -> a -> a
divRoundUp a b = (a + b - 1) `div` b

  | Print splices generated by a TH splice ( the printing will happen during
  compilation , as a GHC warning ) . Useful for debugging .
--
-- For instance, you can dump splices generated with 'makeLenses' by
-- replacing a top-level invocation of 'makeLenses' in your code with:
--
-- @dumpSplices $ makeLenses ''Foo@
--
dumpSplices :: TH.DecsQ -> TH.DecsQ
dumpSplices x = do
    ds <- x
    let code = Prelude.lines (TH.pprint ds)
    TH.reportWarning ("\n" ++ Prelude.unlines (map ("    " ++) code))
    return ds

-- | Count elements in a list.
histogram :: forall a. Ord a => [a] -> Map a Int
histogram = foldl' step M.empty
  where
    step :: Map a Int -> a -> Map a Int
    step m x = M.insertWith (+) x 1 m

median :: Ord a => NonEmpty a -> a
median l = NE.sort l NE.!! middle
  where
    len = NE.length l
    middle = (len - 1) `div` 2

| Sleep for the given duration 

     A numeric literal argument is interpreted as seconds .   In other words , 
     @(sleep 2.0)@ will sleep for two seconds . 
     Taken from  , BSD3 licence . 


    A numeric literal argument is interpreted as seconds.  In other words,
    @(sleep 2.0)@ will sleep for two seconds.
    Taken from , BSD3 licence.
-}
sleep :: MonadIO m => NominalDiffTime -> m ()
sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))

-- | temporary reimplementation of 'ords' from "Formatting"
--   because the original function converts the integer value to a real number
intords :: (Show n, Integral n) => F.Format r (n -> r)
intords = F.later go
  where
    fmt = fromText . pack . show
    go n
      | tens > 3 && tens < 21 = fmt n <> "th"
      | otherwise =
            fmt n <>
            case n `mod` 10 of
              1 -> "st"
              2 -> "nd"
              3 -> "rd"
              _ -> "th"
      where tens = n `mod` 100

  | ' tMeasure ' with '  ' .
tMeasureLog :: (MonadIO m, WithLogger m) => Text -> m a -> m a
tMeasureLog label = fmap fst . tMeasure logDebug label

-- | 'tMeasure' with 'putText'. For places you don't have
-- 'WithLogger' constraint.
tMeasureIO :: (MonadIO m) => Text -> m a -> m a
tMeasureIO label = fmap fst . tMeasure putText label

timed :: (MonadIO m, WithLogger m) => Text -> m a -> m (a, Microsecond)
timed = tMeasure logDebug

  | Takes the first time sample , executes action ( forcing its
  result ) , takes the second time sample , logs it .
tMeasure :: (MonadIO m) => (Text -> m ()) -> Text -> m a -> m (a, Microsecond)
tMeasure logAction label action = do
    before <- liftIO getCurrentTime
    !x <- action
    after <- liftIO getCurrentTime
    let diff :: NominalDiffTime
        diff = after `diffUTCTime` before
        d0 :: Integer
        d0 = round $ 10000 * toRational diff
    let d1 = d0 `div` 10
    let d2 = d0 `mod` 10
    logAction $ "tMeasure " <> label <> ": " <> show d1 <> "." <> show d2 <> "ms"
    pure (x, fromMicroseconds (round $ 1000000 * toRational diff))

# INLINE realTime #
realTime :: MonadIO m => m Microsecond
realTime = liftIO $ round . (* 1000000) <$> getPOSIXTime

# LANGUAGE CPP           #
# LANGUAGE RankNTypes    #
 * Cool stuff
 * Exceptions/errors
 * Ether
 * Lifting monads
 * Logging helpers
 * Misc
--------------------------------------------------------------------------
 Cool stuff
--------------------------------------------------------------------------
--------------------------------------------------------------------------
 Exceptions/errors
--------------------------------------------------------------------------
 what is stored in 'Either'
 | Partial function which calls 'error' with meaningful message if
 given 'Left' and returns some value if given 'Right'.
 Intended usage is when you're sure that value must be right.
 forced on us by external APIs. I also used underscores in its name, so don't
 you think about exporting it -- define a specialized helper instead.

 | Convert an 'Either'-encoded failure to an 'aeson' parser failure. The
 | Convert an 'Either'-encoded failure to a 'cborg' decoder failure. The
 | Convert an 'Either'-encoded failure to a 'TH' Q-monad failure. The
 | Convert an 'Either'-encoded failure to a 'cereal' failure. The
 | Convert an 'Either'-encoded failure to a 'megaparsec' failure. The
--------------------------------------------------------------------------
 Ether
--------------------------------------------------------------------------
 | Make a Reader or State computation work in an Ether transformer. Useful
 to make lenses work with Ether.
 | Convenient shortcut for 'HasLens' constraint when lens is to the
 same type as the tag.
 | Version of 'lensOf' which is used when lens is to the same type
 as the tag.
 | Version of 'lensOf' which uses proxy.
--------------------------------------------------------------------------
 PowerLift
--------------------------------------------------------------------------
# OVERLAPPING #
--------------------------------------------------------------------------
--------------------------------------------------------------------------
--------------------------------------------------------------------------
 Aeson
--------------------------------------------------------------------------
 | Parse a value represented as a 'show'-ed string in JSON.
--------------------------------------------------------------------------
--------------------------------------------------------------------------
 | Makes a span on the list, considering tail only. Predicate has
 | Takes last N elements of the list
--------------------------------------------------------------------------
 Logging helpers
--------------------------------------------------------------------------
 | Formats only start and the end of the list according to the maximum size
 | Catch and log an exception, then rethrow it
 | 'bracket' which logs given message after acquiring the resource
 and before calling the callback with 'Info' severity.
--------------------------------------------------------------------------
 Misc
--------------------------------------------------------------------------
 for restricting type to list of pairs.
 | Use some monadic action to evaluate priority of value and sort a
 list of values based on this priority. The order is descending
 because I need it.
 E.g. @"./dir/" <//> "/file" = "./dir/file"@.
 | To be used with paging of any kind.
 - 1  - 10
 - 11 - 20
 - 21 - 30

 For instance, you can dump splices generated with 'makeLenses' by
 replacing a top-level invocation of 'makeLenses' in your code with:

 @dumpSplices $ makeLenses ''Foo@

 | Count elements in a list.
 | temporary reimplementation of 'ords' from "Formatting"
   because the original function converts the integer value to a real number
 | 'tMeasure' with 'putText'. For places you don't have
 'WithLogger' constraint.
# LANGUAGE DataKinds      #
# LANGUAGE PolyKinds      #
# LANGUAGE TypeFamilies   #
# LANGUAGE TypeOperators #

module Pos.Util.Util
       (
         type (~>)
       , maybeThrow
       , eitherToThrow
       , liftEither
       , leftToPanic
       , toAesonError
       , aesonError
       , toCborError
       , cborError
       , toTemplateHaskellError
       , templateHaskellError
       , toParsecError
       , parsecError
       , toCerealError
       , cerealError
       , DisallowException

       , ether
       , Ether.TaggedTrans
       , HasLens(..)
       , HasLens'
       , lensOf'
       , lensOfProxy

       , PowerLift(..)

  * 
       , MinMax(..)
       , _MinMax
       , mkMinMax
       , minMaxOf

  * 
       , parseJSONWithRead

  * NonEmpty
       , neZipWith3
       , neZipWith4
       , spanSafe
       , takeLastNE

       , buildListBounds
       , multilineBounds
       , logException
       , bracketWithLogging

       , mconcatPair
       , microsecondsToUTC
       , Sign (..)
       , getKeys
       , sortWithMDesc
       , dumpSplices
       , histogram
       , median
       , (<//>)
       , divRoundUp
       , sleep
       , intords

       , tMeasureLog
       , tMeasureIO
       , timed

       , realTime
       ) where

import           Universum

import qualified Codec.CBOR.Decoding as CBOR
import           Control.Concurrent (threadDelay)
import qualified Control.Exception.Safe as E
import           Control.Lens (Getting, Iso', coerced, foldMapOf, ( # ))
import           Control.Monad.Except (MonadError, throwError)
import           Control.Monad.Trans.Class (MonadTrans)
import           Data.Aeson (FromJSON (..))
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import           Data.HashSet (fromMap)
import           Data.List (span, zipWith3, zipWith4)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import           Data.Ratio ((%))
import qualified Data.Semigroup as Smg
import qualified Data.Serialize as Cereal
import           Data.Text (pack)
import           Data.Text.Lazy.Builder (fromText)
import           Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime,
                     getCurrentTime)
import           Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
import           Data.Time.Units (Microsecond, fromMicroseconds, toMicroseconds)
import qualified Ether
import           Ether.Internal (HasLens (..))
import qualified Formatting as F
import           GHC.TypeLits (ErrorMessage (..))
import qualified Language.Haskell.TH as TH
import           Pos.Util.Wlog (LoggerName, WithLogger, logDebug, logError,
                     logInfo, usingLoggerName)
import qualified Prelude
import           Serokell.Util (listJson)
import           Serokell.Util.Exceptions ()
import qualified Text.Megaparsec as P


type f ~> g = forall x. f x -> g x


maybeThrow :: (MonadThrow m, Exception e) => e -> Maybe a -> m a
maybeThrow e = maybe (throwM e) pure

  | Throw exception ( in ' MonadThrow ' ) or return result depending on
eitherToThrow
    :: (MonadThrow m, Exception e)
    => Either e a -> m a
eitherToThrow = either throwM pure

  | ' liftEither ' from mtl-2.2.2 .
  TODO : use mtl version after we start using 2.2.2 .
liftEither
    :: (MonadError e m)
    => Either e a -> m a
liftEither = either throwError pure

leftToPanic :: Buildable a => Text -> Either a b -> b
leftToPanic msgPrefix = either (error . mappend msgPrefix . pretty) identity

  | This unexported helper is used to define conversions to ' MonadFail '
  This must be the only place in our codebase where we allow ' MonadFail ' .
external_api_fail :: MonadFail m => Either Text ~> m
external_api_fail = either (fail . toString) return

  return monad is intentionally specialized because we avoid ' MonadFail ' .
toAesonError :: Either Text ~> A.Parser
toAesonError = external_api_fail

aesonError :: Text -> A.Parser a
aesonError = toAesonError . Left

  return monad is intentionally specialized because we avoid ' MonadFail ' .
toCborError :: Either Text ~> CBOR.Decoder s
toCborError = external_api_fail

cborError :: Text -> CBOR.Decoder s a
cborError = toCborError . Left

  return monad is intentionally specialized because we avoid ' MonadFail ' .
toTemplateHaskellError :: Either Text ~> TH.Q
toTemplateHaskellError = external_api_fail

templateHaskellError :: Text -> TH.Q a
templateHaskellError = toTemplateHaskellError . Left

  return monad is intentionally specialized because we avoid ' MonadFail ' .
toCerealError :: Either Text ~> Cereal.Get
toCerealError = external_api_fail

cerealError :: Text -> Cereal.Get a
cerealError = toCerealError . Left

  return monad is intentionally specialized because we avoid ' MonadFail ' .
toParsecError :: P.Stream s => Either Text ~> P.ParsecT e s m
toParsecError = external_api_fail

parsecError :: P.Stream s => Text -> P.ParsecT e s m a
parsecError = toParsecError . Left

type family DisallowException t :: ErrorMessage where
    DisallowException t =
             'ShowType t ':<>:
             'Text " intentionally doesn't have an 'Exception' instance."
        ':$$: 'Text
             "This type shouldn't be thrown as a runtime exception."
        ':$$: 'Text
             "If you want to throw it, consider defining your own exception \
             \type with a constructor storing a value of this type."
        ':$$: 'Text
             "See the exception handling guidelines for more details."
        ':$$: 'Text ""


ether :: trans m a -> Ether.TaggedTrans tag trans m a
ether = Ether.TaggedTrans

type HasLens' s a = HasLens a s a

lensOf' :: forall a s. HasLens' s a => Lens' s a
lensOf' = lensOf @a

lensOfProxy :: forall proxy tag a b. HasLens tag a b => proxy tag -> Lens' a b
lensOfProxy _ = lensOf @tag


class PowerLift m n where
    powerLift :: m a -> n a

    powerLift = identity

instance (MonadTrans t, PowerLift m n, Monad n) => PowerLift m (t n) where
  powerLift = lift . powerLift @m @n

  MinMax

newtype MinMax a = MinMax (Smg.Option (Smg.Min a, Smg.Max a))
#if MIN_VERSION_base(4,9,0)
  deriving (Smg.Semigroup, Monoid)
#else
  deriving (Monoid)
#endif

_MinMax :: Iso' (MinMax a) (Maybe (a, a))
_MinMax = coerced

mkMinMax :: a -> MinMax a
mkMinMax a = _MinMax # Just (a, a)

minMaxOf :: Getting (MinMax a) s a -> s -> Maybe (a, a)
minMaxOf l = view _MinMax . foldMapOf l mkMinMax


parseJSONWithRead :: Read a => A.Value -> A.Parser a
parseJSONWithRead =
    toAesonError . readEither @String <=<
    parseJSON

  NonEmpty

neZipWith3 :: (x -> y -> z -> q) -> NonEmpty x -> NonEmpty y -> NonEmpty z -> NonEmpty q
neZipWith3 f (x :| xs) (y :| ys) (z :| zs) = f x y z :| zipWith3 f xs ys zs

neZipWith4 ::
       (x -> y -> i -> z -> q)
    -> NonEmpty x
    -> NonEmpty y
    -> NonEmpty i
    -> NonEmpty z
    -> NonEmpty q
neZipWith4 f (x :| xs) (y :| ys) (i :| is) (z :| zs) = f x y i z :| zipWith4 f xs ys is zs

  list head as first argument . Used to take non - null prefix that
  depends on the first element .
spanSafe :: (a -> a -> Bool) -> NonEmpty a -> (NonEmpty a, [a])
spanSafe p (x:|xs) = let (a,b) = span (p x) xs in (x:|a,b)

takeLastNE :: Int -> NonEmpty a -> [a]
takeLastNE n = reverse . NE.take n . NE.reverse


  | Formats two values as first and last elements of a list
buildListBounds :: Buildable a => F.Format r (NonEmpty a -> r)
buildListBounds = F.later formatList
  where
    formatList (x:|[]) = F.bprint ("[" F.% F.build F.% "]") x
    formatList xs = F.bprint ("[" F.% F.build F.% ".." F.% F.build F.% "]")
        (NE.head xs)
        (NE.last xs)

multilineBounds :: Buildable a => Int -> F.Format r (NonEmpty a -> r)
multilineBounds maxSize = F.later formatList
 where
   formatList xs = if length xs <= maxSize'
       then F.bprint listJson xs
       else F.bprint
          ("First " F.% F.int F.% ": " F.% listJson F.% "\nLast " F.% F.int F.% ": " F.% listJson)
          half
          (NE.take half xs)
          remaining
          (takeLastNE remaining xs)
  splitting list into two with maximum size below 2 does n't make sense
   half = maxSize' `div` 2
   remaining = maxSize' - half

logException :: LoggerName -> IO a -> IO a
logException name = E.handleAsync (\e -> handler e >> E.throw e)
  where
    handler :: E.SomeException -> IO ()
    handler exc = do
        let message = "logException: " <> pretty exc
        usingLoggerName name (logError message) `E.catchAny` \loggingExc -> do
            putStrLn message
            putStrLn $
                "logException failed to use logging: " <> pretty loggingExc

bracketWithLogging ::
       (MonadMask m, WithLogger m)
    => Text
    -> m a
    -> (a -> m b)
    -> (a -> m c)
    -> m c
bracketWithLogging msg acquire release = bracket acquire release . addLogging
  where
    addLogging callback resource = do
        logInfo $ "<bracketWithLogging:before> " <> msg
        callback resource <*
            logInfo ("<bracketWithLogging:after> " <> msg)


  | Specialized version of ' mconcat ' ( or ' Data.Foldable.fold ' )
mconcatPair :: (Monoid a, Monoid b) => [(a, b)] -> (a, b)
mconcatPair = mconcat

microsecondsToUTC :: Microsecond -> UTCTime
microsecondsToUTC = posixSecondsToUTCTime . fromRational . (% 1000000) . toMicroseconds

data Sign = Plus | Minus

  | Create HashSet from HashMap 's keys
getKeys :: HashMap k v -> HashSet k
getKeys = fromMap . void

sortWithMDesc :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
sortWithMDesc f = fmap (map fst . sortWith (Down . snd)) . mapM f'
  where
    f' x = (x, ) <$> f x

  | Concatenates two url parts using regular slash ' / ' .
(<//>) :: String -> String -> String
(<//>) lhs rhs = lhs' ++ "/" ++ rhs'
  where
    isSlash = (== '/')
    lhs' = reverse $ dropWhile isSlash $ reverse lhs
    rhs' = dropWhile isSlash rhs

  The pages should contain N elements ( we use 10 by default ):
divRoundUp :: Integral a => a -> a -> a
divRoundUp a b = (a + b - 1) `div` b

  | Print splices generated by a TH splice ( the printing will happen during
  compilation , as a GHC warning ) . Useful for debugging .
dumpSplices :: TH.DecsQ -> TH.DecsQ
dumpSplices x = do
    ds <- x
    let code = Prelude.lines (TH.pprint ds)
    TH.reportWarning ("\n" ++ Prelude.unlines (map ("    " ++) code))
    return ds

histogram :: forall a. Ord a => [a] -> Map a Int
histogram = foldl' step M.empty
  where
    step :: Map a Int -> a -> Map a Int
    step m x = M.insertWith (+) x 1 m

median :: Ord a => NonEmpty a -> a
median l = NE.sort l NE.!! middle
  where
    len = NE.length l
    middle = (len - 1) `div` 2

| Sleep for the given duration 

     A numeric literal argument is interpreted as seconds .   In other words , 
     @(sleep 2.0)@ will sleep for two seconds . 
     Taken from  , BSD3 licence . 


    A numeric literal argument is interpreted as seconds.  In other words,
    @(sleep 2.0)@ will sleep for two seconds.
    Taken from , BSD3 licence.
-}
sleep :: MonadIO m => NominalDiffTime -> m ()
sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))

intords :: (Show n, Integral n) => F.Format r (n -> r)
intords = F.later go
  where
    fmt = fromText . pack . show
    go n
      | tens > 3 && tens < 21 = fmt n <> "th"
      | otherwise =
            fmt n <>
            case n `mod` 10 of
              1 -> "st"
              2 -> "nd"
              3 -> "rd"
              _ -> "th"
      where tens = n `mod` 100

  | ' tMeasure ' with '  ' .
tMeasureLog :: (MonadIO m, WithLogger m) => Text -> m a -> m a
tMeasureLog label = fmap fst . tMeasure logDebug label

tMeasureIO :: (MonadIO m) => Text -> m a -> m a
tMeasureIO label = fmap fst . tMeasure putText label

timed :: (MonadIO m, WithLogger m) => Text -> m a -> m (a, Microsecond)
timed = tMeasure logDebug

  | Takes the first time sample , executes action ( forcing its
  result ) , takes the second time sample , logs it .
tMeasure :: (MonadIO m) => (Text -> m ()) -> Text -> m a -> m (a, Microsecond)
tMeasure logAction label action = do
    before <- liftIO getCurrentTime
    !x <- action
    after <- liftIO getCurrentTime
    let diff :: NominalDiffTime
        diff = after `diffUTCTime` before
        d0 :: Integer
        d0 = round $ 10000 * toRational diff
    let d1 = d0 `div` 10
    let d2 = d0 `mod` 10
    logAction $ "tMeasure " <> label <> ": " <> show d1 <> "." <> show d2 <> "ms"
    pure (x, fromMicroseconds (round $ 1000000 * toRational diff))

# INLINE realTime #
realTime :: MonadIO m => m Microsecond
realTime = liftIO $ round . (* 1000000) <$> getPOSIXTime
