mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 18:42:30 +03:00
904029aa7d
## Suggestion: Add fancier trace debugging functions to `Hasura.Prelude` This PR adds two trace functions, `ltrace` and `ltraceM`, which use the `pretty-simple` package to `show` the input with nice formatting and colors for ease of reading (and comparing using diff tools such as `meld` or `vim-diff`). I've also added warning pragmas to the functions, which means: 1. Traces will not be left in code, as CI builds with -Werror 2. Developers will have to change the `ghc-options` to `-Wwarn` in their `cabal.project.local` settings to use these functions ### Example Usage: ```hs selectFunctionAggregate ... = ... do ltraceM "functionInfo" function ... ``` Output to terminal looks like this: <img width="524" alt="Screen Shot 2021-08-12 at 10 33 24" src="https://user-images.githubusercontent.com/8547573/129158878-4a5e96ba-30a5-452c-8f33-9eb4b2cc5e2a.png"> ### Dependencies Requires adding the following dependencies: - prettyprinter-ansi-terminal-1.1.2 (BSD2) - pretty-simple-4.0.0.0 (BSD3) Question: what is the process for adding new dependencies? How does decisions on this matter happen? https://github.com/hasura/graphql-engine-mono/pull/2075 GitOrigin-RevId: 490b0f0ca595da319b43e92e190ba50c0b132cd5
254 lines
9.2 KiB
Haskell
254 lines
9.2 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Hasura.Prelude
|
|
( module M
|
|
, alphabet
|
|
, alphaNumerics
|
|
, onNothing
|
|
, onJust
|
|
, onLeft
|
|
, whenMaybe
|
|
, choice
|
|
, afold
|
|
, bsToTxt
|
|
, lbsToTxt
|
|
, txtToBs
|
|
, base64Decode
|
|
, spanMaybeM
|
|
, liftEitherM
|
|
, hoistMaybe
|
|
, hoistEither
|
|
, tshow
|
|
-- * Trace debugging
|
|
, ltrace
|
|
, ltraceM
|
|
-- * Efficient coercions
|
|
, coerce
|
|
, findWithIndex
|
|
-- * Map-related utilities
|
|
, mapFromL
|
|
, mapKeys
|
|
, oMapFromL
|
|
-- * Measuring and working with moments and durations
|
|
, withElapsedTime
|
|
, startTimer
|
|
-- * Aeson options
|
|
, hasuraJSON
|
|
-- * Extensions to @Data.Foldable@
|
|
, fold'
|
|
, module Data.Time.Clock.Units
|
|
) where
|
|
|
|
import Control.Applicative as M (Alternative (..), liftA2)
|
|
import Control.Arrow as M (first, second, (&&&), (***), (<<<), (>>>))
|
|
import Control.DeepSeq as M (NFData, deepseq, force)
|
|
import Control.Lens as M (ix, (%~))
|
|
import Control.Monad.Base as M
|
|
import Control.Monad.Except as M
|
|
import Control.Monad.Identity as M
|
|
import Control.Monad.Reader as M
|
|
import Control.Monad.State.Strict as M
|
|
import Control.Monad.Trans.Maybe as M (MaybeT (..))
|
|
import Control.Monad.Writer.Strict as M (MonadWriter (..), WriterT (..), execWriterT,
|
|
runWriterT)
|
|
import Data.Align as M (Semialign (align, alignWith))
|
|
import Data.Bool as M (bool)
|
|
import Data.Coerce
|
|
import Data.Data as M (Data (..))
|
|
import Data.Either as M (lefts, partitionEithers, rights)
|
|
import Data.Foldable as M (asum, fold, foldMap', foldlM, foldrM, for_,
|
|
toList, traverse_)
|
|
import Data.Function as M (on, (&))
|
|
import Data.Functor as M (($>), (<&>))
|
|
import Data.Functor.Const as M (Const)
|
|
import Data.HashMap.Strict as M (HashMap)
|
|
import Data.HashMap.Strict.InsOrd as M (InsOrdHashMap)
|
|
import Data.HashSet as M (HashSet)
|
|
import Data.Hashable as M (Hashable)
|
|
import Data.List as M (find, findIndex, foldl', group, intercalate,
|
|
intersect, lookup, sort, sortBy, sortOn, union,
|
|
unionBy, (\\))
|
|
import Data.List.NonEmpty as M (NonEmpty (..), nonEmpty)
|
|
import Data.Maybe as M (catMaybes, fromMaybe, isJust, isNothing,
|
|
listToMaybe, mapMaybe, maybeToList)
|
|
import Data.Monoid as M (getAlt)
|
|
import Data.Ord as M (comparing)
|
|
import Data.Semigroup as M (Semigroup (..))
|
|
import Data.Sequence as M (Seq)
|
|
import Data.Sequence.NonEmpty as M (NESeq)
|
|
import Data.String as M (IsString)
|
|
import Data.Text as M (Text)
|
|
import Data.These as M (These (..), fromThese, mergeThese,
|
|
mergeTheseWith, partitionThese, these)
|
|
import Data.Time.Clock.Units
|
|
import Data.Traversable as M (for)
|
|
import Data.Void as M (Void, absurd)
|
|
import Data.Word as M (Word64)
|
|
import GHC.Generics as M (Generic)
|
|
import Prelude as M hiding (fail, init, lookup)
|
|
import Text.Read as M (readEither, readMaybe)
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.Casing as J
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Base64.Lazy as Base64
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.HashMap.Strict.InsOrd as OMap
|
|
import qualified Data.Hashable as H
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Text.Encoding.Error as TE
|
|
import qualified Data.Text.Lazy as TL
|
|
import qualified GHC.Clock as Clock
|
|
|
|
import Debug.Trace (trace, traceM)
|
|
import qualified Text.Pretty.Simple as PS
|
|
|
|
alphabet :: String
|
|
alphabet = ['a'..'z'] ++ ['A'..'Z']
|
|
|
|
alphaNumerics :: String
|
|
alphaNumerics = alphabet ++ "0123456789"
|
|
|
|
onNothing :: Applicative m => Maybe a -> m a -> m a
|
|
onNothing m act = maybe act pure m
|
|
|
|
onJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
|
|
onJust m action = maybe (pure ()) action m
|
|
|
|
onLeft :: Applicative m => Either e a -> (e -> m a) -> m a
|
|
onLeft e f = either f pure e
|
|
|
|
whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a)
|
|
whenMaybe True = fmap Just
|
|
whenMaybe False = const $ pure Nothing
|
|
|
|
choice :: Alternative f => [f a] -> f a
|
|
choice = asum
|
|
|
|
afold :: (Foldable t, Alternative f) => t a -> f a
|
|
afold = getAlt . foldMap pure
|
|
|
|
bsToTxt :: B.ByteString -> Text
|
|
bsToTxt = TE.decodeUtf8With TE.lenientDecode
|
|
|
|
lbsToTxt :: BL.ByteString -> Text
|
|
lbsToTxt = bsToTxt . BL.toStrict
|
|
|
|
txtToBs :: Text -> B.ByteString
|
|
txtToBs = TE.encodeUtf8
|
|
|
|
base64Decode :: Text -> BL.ByteString
|
|
base64Decode =
|
|
Base64.decodeLenient . BL.fromStrict . txtToBs
|
|
|
|
-- Like `liftEither`, but accepts a monadic action
|
|
liftEitherM :: MonadError e m => m (Either e a) -> m a
|
|
liftEitherM action = action >>= liftEither
|
|
|
|
-- Like 'span', but monadic and with a function that produces 'Maybe' instead of 'Bool'
|
|
spanMaybeM
|
|
:: (Foldable f, Monad m)
|
|
=> (a -> m (Maybe b)) -> f a -> m ([b], [a])
|
|
spanMaybeM f = go . toList
|
|
where
|
|
go [] = pure ([], [])
|
|
go l@(x:xs) = f x >>= \case
|
|
Just y -> first (y:) <$> go xs
|
|
Nothing -> pure ([], l)
|
|
|
|
findWithIndex :: (a -> Bool) -> [a] -> Maybe (a, Int)
|
|
findWithIndex p l = do
|
|
v <- find p l
|
|
i <- findIndex p l
|
|
pure (v, i)
|
|
|
|
-- TODO (from main): Move to Data.HashMap.Strict.Extended; rename to fromListWith?
|
|
mapFromL :: (Eq k, Hashable k) => (a -> k) -> [a] -> Map.HashMap k a
|
|
mapFromL f = Map.fromList . map (\v -> (f v, v))
|
|
|
|
-- | re-key a map. In the case that @f@ is not injective you may end up with a
|
|
-- smaller map than what you started with.
|
|
--
|
|
-- This may be a code smell.
|
|
mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> Map.HashMap k1 a -> Map.HashMap k2 a
|
|
mapKeys f = Map.fromList . map (first f) . Map.toList
|
|
|
|
oMapFromL :: (Eq k, Hashable k) => (a -> k) -> [a] -> InsOrdHashMap k a
|
|
oMapFromL f = OMap.fromList . map (\v -> (f v, v))
|
|
|
|
-- | Time an IO action, returning the time with microsecond precision. The
|
|
-- result of the input action will be evaluated to WHNF.
|
|
--
|
|
-- The result 'DiffTime' is guarenteed to be >= 0.
|
|
withElapsedTime :: MonadIO m => m a -> m (DiffTime, a)
|
|
withElapsedTime ma = do
|
|
bef <- liftIO Clock.getMonotonicTimeNSec
|
|
!a <- ma
|
|
aft <- liftIO Clock.getMonotonicTimeNSec
|
|
let !dur = nanoseconds $ fromIntegral (aft - bef)
|
|
return (dur, a)
|
|
|
|
-- | Start timing and return an action to return the elapsed time since 'startTimer' was called.
|
|
--
|
|
-- @
|
|
-- timer <- startTimer
|
|
-- someStuffToTime
|
|
-- elapsed <- timer
|
|
-- moreStuff
|
|
-- elapsedBoth <- timer
|
|
-- @
|
|
startTimer :: (MonadIO m, MonadIO n) => m (n DiffTime)
|
|
startTimer = do
|
|
!bef <- liftIO Clock.getMonotonicTimeNSec
|
|
return $ do
|
|
aft <- liftIO Clock.getMonotonicTimeNSec
|
|
return $ nanoseconds $ fromIntegral (aft - bef)
|
|
|
|
-- | Upgrade a 'Maybe' to a 'MaybeT'.
|
|
--
|
|
-- cf. http://hackage.haskell.org/package/errors-2.3.0/docs/src/Control.Error.Util.html#hoistMaybe
|
|
hoistMaybe :: Applicative m => Maybe b -> MaybeT m b
|
|
hoistMaybe = MaybeT . pure
|
|
|
|
-- | Upgrade an 'Either' to an 'ExceptT'.
|
|
--
|
|
-- cf. http://hackage.haskell.org/package/errors-2.3.0/docs/src/Control.Error.Util.html#hoistEither
|
|
hoistEither :: Applicative m => Either e a -> ExceptT e m a
|
|
hoistEither = ExceptT . pure
|
|
|
|
tshow :: Show a => a -> Text
|
|
tshow = T.pack . show
|
|
|
|
-- | Customized 'J.Options' which apply "snake case" to Generic or Template
|
|
-- Haskell JSON derivations.
|
|
--
|
|
-- For example, a Haskell field @fooBar@ would be de/serialized from/to JSON as
|
|
-- @foo_bar@.
|
|
hasuraJSON :: J.Options
|
|
hasuraJSON = J.aesonPrefix J.snakeCase
|
|
|
|
instance (Hashable a) => Hashable (Seq a) where
|
|
hashWithSalt i = H.hashWithSalt i . toList
|
|
|
|
-- | Given a structure with elements whose type is a 'Monoid', combine them via
|
|
-- the monoid's @('<>')@ operator.
|
|
--
|
|
-- This fold is right-associative and strict in the accumulator; it's defined
|
|
-- as @foldMap id@, per the documentation in @Data.Foldable@.
|
|
fold' :: (Monoid m, Foldable t) => t m -> m
|
|
fold' = foldMap' id
|
|
|
|
-- Fancy trace debugging
|
|
|
|
-- | Labeled, prettified traceShowId
|
|
ltrace :: Show a => String -> a -> a
|
|
ltrace lbl x = trace (lbl <> ": " <> TL.unpack (PS.pShow x)) x
|
|
{-# warning ltrace "ltrace left in code" #-}
|
|
|
|
-- | Labeled, prettified traceShowM
|
|
ltraceM :: Applicative m => Show a => String -> a -> m ()
|
|
ltraceM lbl x = traceM (lbl <> ": " <> TL.unpack (PS.pShow x))
|
|
{-# warning ltraceM "ltraceM left in code" #-}
|