packages feed

trace-embrace (empty) → 1.0.2

raw patch · 33 files changed

+2345/−0 lines, 33 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, cpphs, deepseq, directory, filepath, generic-lens, ghc, lens, lrucache, radix-tree, refined, tagged, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, trace-embrace, transformers, yaml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2025 Daniil Iaitskov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Edward Kmett nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ changelog.md view
@@ -0,0 +1,3 @@+# trace-embrace changelog++## Version 1.0.2 2025-03-06
+ src/Debug/TraceEmbrace.hs view
@@ -0,0 +1,6 @@+-- | The root module to be imported by applications and libraries.+module Debug.TraceEmbrace (ShowTrace (..), module TT) where++import Debug.TraceEmbrace.Config as TT+import Debug.TraceEmbrace.ByteString (ShowTrace (..))+import Debug.TraceEmbrace.TH as TT
+ src/Debug/TraceEmbrace/ByteString.hs view
@@ -0,0 +1,35 @@+module Debug.TraceEmbrace.ByteString where++import Data.ByteString.Lazy.Internal qualified as L+import Data.ByteString.Internal (ByteString(..))+import Data.Tagged+import Data.Maybe+import Prelude++-- | Show 'ByteString' structure.+--+-- >>> showLbsAsIs ("a" <> "b")+showLbsAsIs :: L.ByteString -> [ByteString]+showLbsAsIs L.Empty = []+showLbsAsIs (L.Chunk x xs) = x : showLbsAsIs xs++-- | Wrap value which has opaque 'Show' instance.+newtype ShowTrace a = ShowTrace { unShowTrace :: a }++instance Show (ShowTrace L.ByteString) where+  show = show . showLbsAsIs . unShowTrace++instance Show (ShowTrace ByteString) where+  show (ShowTrace bs@(BS fp len)) = "BS " <> show fp <> " " <> show len <> ":" <> show bs++instance Show (ShowTrace a) => Show (ShowTrace (Maybe a)) where+  show (ShowTrace x) = show (ShowTrace <$> x)++instance Show (ShowTrace a) => Show (ShowTrace (Tagged t a)) where+  show (ShowTrace x) = show (ShowTrace <$> x)++instance {-# OVERLAPPABLE #-} Show (ShowTrace a) => Show (ShowTrace [a]) where+  show (ShowTrace x) = show (ShowTrace <$> x)++instance {-# OVERLAPPING #-} Show (ShowTrace a) => Show (ShowTrace [Tagged t a]) where+  show (ShowTrace x) = show (fmap ShowTrace <$> x)
+ src/Debug/TraceEmbrace/Config.hs view
@@ -0,0 +1,4 @@+module Debug.TraceEmbrace.Config (module X) where++import Debug.TraceEmbrace.Config.Type as X+import Debug.TraceEmbrace.Config.Load as X
+ src/Debug/TraceEmbrace/Config/Load.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Config.Load where++import Control.Concurrent.MVar+import Control.Exception+import Data.Cache.LRU as LRU+import Data.Char+import Data.Generics.Labels ()+import Data.IORef+import Data.List qualified as L+import Data.RadixTree.Word8.Strict qualified as T+import Data.Yaml as Y+import Debug.Trace (traceIO)+import Debug.TraceEmbrace.Config.Type+import Debug.TraceEmbrace.Config.Validation+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Refined+import System.Directory+import System.Environment (lookupEnv)+import System.IO+import System.IO.Unsafe+++validateTraceMessageFormat ::+  String ->+  TraceMessageFormatMaybe ->+  Either String (Refined IdPred TraceMessageFormat)+validateTraceMessageFormat fieldName ytc =+  refineS fieldName =<< TraceMessageFormat+  <$> required "entrySeparator" ytc.entrySeparator+  <*> required "keyValueSeparator" ytc.keyValueSeparator+  <*> required "retValPrefix" ytc.retValPrefix+  <*> required "traceLinePattern" ytc.traceLinePattern++validateYamlConfig :: YamlConfigMaybe -> Either String YamlConfig+validateYamlConfig yc =+  YamlConfig+  <$> required "mode" yc.mode+  <*> required "version" yc.version+  <*> (required  "traceMessage" yc.traceMessage >>=+       validateTraceMessageFormat "traceMessage" . unrefine @IdPred)+  <*> required "levels" yc.levels+  <*> required "runtimeLevelsOverrideEnvVar" yc.runtimeLevelsOverrideEnvVar++defaultTraceMessageFormatYaml :: TraceMessageFormatMaybe+defaultTraceMessageFormatYaml = TraceMessageFormat+  { entrySeparator = Just "; "+  , keyValueSeparator = Just ": "+  , retValPrefix = Just " => "+  , traceLinePattern =+    Just+    [ FullyQualifiedModule+    , Delimiter "::"+    , FunctionName+    , Delimiter ": "+    , LiteralMessage+    , Variables+    ]+  }++defaultTraceMessageFormat :: TraceMessageFormat+defaultTraceMessageFormat =+  either (error "defaultTraceMessageFormatYaml is partial") unrefine $+    validateTraceMessageFormat "traceMessageFormat" defaultTraceMessageFormatYaml++newYamlConfig :: YamlConfigMaybe+newYamlConfig =+  YamlConfig+  { mode = Just TraceStd+  , version = Just 1+  , traceMessage = Just defaultTraceMessageFormatYaml+  , levels = Just [ LeveledModulePrefix Trace "" ]+  , runtimeLevelsOverrideEnvVar = Just CapsPackageName+  }++defaultYamlConfig :: YamlConfigMaybe+defaultYamlConfig = newYamlConfig { version = Nothing }++loadYamlConfig :: IO YamlConfig+loadYamlConfig = do+  doesFileExist fp >>= \case+    True -> configFromJust . (<> defaultYamlConfig) =<< catch (Y.decodeFileThrow fp) badYaml+    False -> do+      Y.encodeFile fp newYamlConfig+      traceIO $ "New default config trace-embrace file is generated: [" <> fp <> "]"+      configFromJust newYamlConfig+  where+    configFromJust :: YamlConfigMaybe -> IO YamlConfig+    configFromJust ycm =+      either (\e -> fail $ show ycm <> "\nNot valid due: " <> e) pure+        $ validateYamlConfig ycm+    badYaml e =+      fail $ "Fail to parse " <> show fp <> "file due:\n" <> prettyPrintParseException e+      <> "\nRename or delete existing config file to get default config."+    fp = traceEmbraceConfigFileName++traceEmbraceConfigFileName :: FilePath+traceEmbraceConfigFileName = "trace-embrace.yaml"++traceEmbraceConfigRef :: IORef (Maybe TraceEmbraceConfig)+traceEmbraceConfigRef = unsafePerformIO (newIORef Nothing)+{-# NOINLINE traceEmbraceConfigRef #-}++unsafeIoSink :: IORef (Maybe Handle)+unsafeIoSink = unsafePerformIO (newIORef Nothing)+{-# NOINLINE unsafeIoSink #-}++newtype DynConfigEnvVar = DynConfigEnvVar String deriving (Eq, Show, Ord, Lift)++runtimeTraceEmbraceConfigRef :: MVar (LRU DynConfigEnvVar (T.StrictRadixTree TraceLevel))+runtimeTraceEmbraceConfigRef = unsafePerformIO (newMVar $ newLRU (Just 7))+{-# NOINLINE runtimeTraceEmbraceConfigRef #-}++mkPrefixTree :: [LeveledModulePrefix] -> T.StrictRadixTree TraceLevel+mkPrefixTree = L.foldl' go T.empty+  where+    go b e = T.insert (T.feedText e.modulePrefix) e.level b++yaml2Config :: YamlConfig -> TraceEmbraceConfig+yaml2Config yc =+  TraceEmbraceConfig (unrefine $ yc.mode) (unrefine $ yc.traceMessage)+  (mkPrefixTree . unrefine $ yc.levels)+  (unrefine $ yc.runtimeLevelsOverrideEnvVar)++getConfig :: Q TraceEmbraceConfig+getConfig = go+  where+    go = runIO (readIORef traceEmbraceConfigRef) >>= \case+      Nothing -> do+        c <- yaml2Config <$> runIO loadYamlConfig+        runIO (atomicWriteIORef traceEmbraceConfigRef (Just c))+        addDependentFile traceEmbraceConfigFileName+        pure c+      Just c -> pure c+++traceAll :: [LeveledModulePrefix]+traceAll = emptyPrefixTraceLevel Trace++emptyPrefixTraceLevel :: TraceLevel -> [LeveledModulePrefix]+emptyPrefixTraceLevel tl =+  [ LeveledModulePrefix+    { level = tl+    , modulePrefix = ""+    }+  ]++loadRuntimeConfig :: DynConfigEnvVar -> IO (T.StrictRadixTree TraceLevel)+loadRuntimeConfig (DynConfigEnvVar evar) = do+  lookupEnv evar >>= \case+    Nothing -> pure $ mkPrefixTree traceAll+    Just "" -> pure T.empty+    Just "-" -> pure T.empty+    Just fp -> mkPrefixTree <$> loadRuntimeConfigFromYamlFile fp++loadRuntimeConfigFromYamlFile :: FilePath -> IO [LeveledModulePrefix]+loadRuntimeConfigFromYamlFile [] = pure [] -- disable all logs+loadRuntimeConfigFromYamlFile fp =+  doesFileExist fp >>= \case+    True ->+      catch (Y.decodeFileThrow fp) badYaml <* (traceIO $ "trace-embrace runtime config loaded from "+                                                <> show fp)+    False -> do+      traceIO $ "trace-embrace runtime config file " <> show fp+        <> " is missing - disable tracing"+      pure traceAll+  where+    badYaml e =+      fail $ "Fail to parse trace-embrace runtime config from file " <> show fp <> " due:\n"+      <> prettyPrintParseException e++getRuntimeConfig :: DynConfigEnvVar -> IO (T.StrictRadixTree TraceLevel)+getRuntimeConfig evar = modifyMVar runtimeTraceEmbraceConfigRef go+  where+    go lru =+      case LRU.lookup evar lru of+        (lru', Just dynCon) -> pure (lru', dynCon)+        (_, Nothing) -> loadRuntimeConfig evar >>=+          \c -> pure (LRU.insert evar c lru, c)++markerConfig :: TraceEmbraceConfig+markerConfig = TraceEmbraceConfig+    { mode = TraceEvent+    , traceMessage =+        TraceMessageFormat+        ($$(refineTH "e") :: Refined SeparatorValidator String)+        ($$(refineTH "e") :: Refined SeparatorValidator String)+        ($$(refineTH "e") :: Refined SeparatorValidator String)+        ($$(refineTH [ ModuleName, Delimiter "::", FunctionName ]) :: Refined NonEmpty [TraceMessageElement])+    , levels = mkPrefixTree traceAll+    , runtimeLevelsOverrideEnvVar = Ignored+    }++envVarName :: Loc -> EnvironmentVariable -> Maybe DynConfigEnvVar+envVarName loc = fmap DynConfigEnvVar . \case+  Ignored -> Nothing+  CapsPackageName ->+    Just . (packageBasedEnvVarPrefix <>) . dropSuffix+    $ toUpper . underscoreNonAlphaNum+    <$> loc_package loc+  EnvironmentVariable evar -> Just evar+  where+    dropSuffix ('_':h:t)+       | isDigit h = []+       | otherwise = '_' : (dropSuffix $ h : t)+    dropSuffix (o:t) =  o : dropSuffix t+    dropSuffix [] = []++    underscoreNonAlphaNum c+      | isAlphaNum c = c+      | otherwise = '_'
+ src/Debug/TraceEmbrace/Config/Type.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Debug.TraceEmbrace.Config.Type+  ( module E+  , YamlConfigG (..)+  , YamlConfig+  , YamlConfigMaybe+  , TraceEmbraceConfig (..)+  ) where++import Control.Applicative+import Control.Lens hiding (levels)+import Data.Aeson hiding (Error)+import Data.Generics.Labels ()+import Data.RadixTree.Word8.Strict qualified as T+import Debug.TraceEmbrace.Config.Type.Mode as E+import Debug.TraceEmbrace.Config.Type.EnvVar as E+import Debug.TraceEmbrace.Config.Type.Level as E+import Debug.TraceEmbrace.Config.Type.TraceMessage as E+import Debug.TraceEmbrace.Config.Validation+import GHC.Generics+import Refined++data YamlConfigG a+  = YamlConfig+    { mode :: Columnar a SinkModeP SinkMode+    , version :: Columnar a (And (GreaterThan 0) (LessThan 2)) Int+    , traceMessage :: Columnar a IdPred (TraceMessageFormatG a)+    , levels :: Columnar a HaskellModulePrefixP [ LeveledModulePrefix ]+    , runtimeLevelsOverrideEnvVar :: Columnar a EnvironmentVariableP EnvironmentVariable+    }++type YamlConfig = YamlConfigG Identity+type YamlConfigMaybe = YamlConfigG Maybe++deriving instance Generic YamlConfigMaybe+deriving instance Generic YamlConfig+deriving instance Show YamlConfig+deriving instance Eq YamlConfig+instance ToJSON YamlConfig where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON YamlConfig+deriving instance Show YamlConfigMaybe+deriving instance Eq YamlConfigMaybe+instance ToJSON YamlConfigMaybe where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON YamlConfigMaybe++instance Semigroup YamlConfigMaybe where+  a <> b =+    YamlConfig+    (a.mode <|> b.mode)+    (a.version <|> b.version)+    (a.traceMessage <> b.traceMessage)+    (a.levels <|> b.levels)+    (a.runtimeLevelsOverrideEnvVar <|> b.runtimeLevelsOverrideEnvVar)++data TraceEmbraceConfig+  = TraceEmbraceConfig+    { mode :: SinkMode+    , traceMessage :: TraceMessageFormat+    , levels :: T.StrictRadixTree TraceLevel+    , runtimeLevelsOverrideEnvVar :: EnvironmentVariable+    } deriving (Eq, Show, Generic)
+ src/Debug/TraceEmbrace/Config/Type/EnvVar.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Config.Type.EnvVar where++import Data.Aeson hiding (Error)+import Data.Char+import Data.Generics.Labels ()+import Data.Text qualified as T+import Data.Typeable+import GHC.Generics+import Refined++packageBasedEnvVarPrefix :: String+packageBasedEnvVarPrefix = "TRACE_EMBRACE_"++-- | Name of environment variable name.+data EnvironmentVariable+  = Ignored+  -- | Use upcased package name non alphanum chars are replaced with @_@,+  -- plus @TRACE_EMBRACE_@ prefix+  | CapsPackageName -- ^+  | EnvironmentVariable { varName :: String }+  deriving (Eq, Show, Ord, Generic)++instance ToJSON EnvironmentVariable where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON EnvironmentVariable+++data EnvironmentVariableP++instance Predicate EnvironmentVariableP EnvironmentVariable where+  validate p = \case+    Ignored -> Nothing+    CapsPackageName -> Nothing+    EnvironmentVariable n ->+      case n of+        [] -> throwRefineOtherException (typeRep p) "Environment variable name cannot be empty"+        (h:t)+          | isUpper h && all (\c -> isUpper c || c == '_' || isDigit c) t -> Nothing+          | otherwise ->+            throwRefineOtherException (typeRep p)+              ("Bad environment variable name: " <> T.pack (show n))
+ src/Debug/TraceEmbrace/Config/Type/Level.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Config.Type.Level where++import Control.Monad+import Data.Aeson hiding (Error)+import Data.Char+import Data.Generics.Labels ()+import Data.List qualified as L+import Data.Maybe+import Data.Text qualified as T+import Data.Typeable+import GHC.Generics+import Language.Haskell.TH.Syntax+import Refined+++data TraceLevel+  = Trace+  | Info+  | Warning+  | Error+  | TracingDisabled+  deriving (Eq, Show, Ord, Lift, Generic, Bounded, Enum)++traceLevelToChar :: TraceLevel -> T.Text+traceLevelToChar = \case+  Trace -> "-"+  Info -> ""+  Warning -> "!"+  Error -> "|"+  TracingDisabled -> "#"++charToLevel :: String -> (TraceLevel, String)+charToLevel [] = (Info, "")+charToLevel s@(l:m)=+  case l of+    '-' -> (Trace, m)+    '!' -> (Warning, m)+    '|' -> (Error, m)+    '#' -> (TracingDisabled, m)+    _   -> (Info,  s)++data HaskellModulePrefixP++data LeveledModulePrefix+  = LeveledModulePrefix+    { level :: TraceLevel+    , modulePrefix :: T.Text+    } deriving (Eq, Show, Generic)++instance Predicate HaskellModulePrefixP LeveledModulePrefix where+  validate pr p = case T.uncons p.modulePrefix of+    Nothing -> Nothing+    Just _+      | T.any (\c -> not (isAlphaNum c) && c /= '_' && c /= '.') p.modulePrefix ->+          throwRefineOtherException (typeRep pr)+            ("Module prefix can contain letters, digits, dots and underbars only but: ["+              <> p.modulePrefix <> "]")+      | any (not . isUpper . fst . fromMaybe ('A', "") . T.uncons) $ T.split (== '.') p.modulePrefix ->+          throwRefineOtherException (typeRep pr)+                 ("Module prefix segment should start with a capital letter but: ["+                  <> p.modulePrefix <> "]")+      | otherwise -> Nothing++instance Predicate HaskellModulePrefixP [LeveledModulePrefix] where+  validate pr pp = join $ L.find isJust (validate pr<$> pp)++instance ToJSON LeveledModulePrefix where+  toJSON o = String $ traceLevelToChar o.level <> o.modulePrefix+instance FromJSON LeveledModulePrefix where+  parseJSON (String x) =+    pure . uncurry LeveledModulePrefix . fmap T.pack . charToLevel $ T.unpack x+  parseJSON o =+    fail $ "Failed to parse [" <> show o+      <> "] as LeveledModulePrefix because String is expected"
+ src/Debug/TraceEmbrace/Config/Type/Mode.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Config.Type.Mode where++import Data.Aeson hiding (Error)+import Data.Generics.Labels ()+import Data.Typeable+import GHC.Generics+import Language.Haskell.TH.Syntax+import Refined++data IoSink+  = StdErrSink+  | StdOutSink+  | FileSink FilePath deriving (Eq, Show, Generic, Lift)++instance ToJSON IoSink where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON IoSink++data SinkMode+  = TraceDisabled+  | TraceStd+  | TraceUnsafeIo { sink :: IoSink }+  | TraceEvent+  deriving (Eq, Show, Generic)++instance ToJSON SinkMode where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON SinkMode++data SinkModeP++instance Predicate SinkModeP SinkMode where+  validate p = \case+    TraceDisabled -> Nothing+    TraceStd -> Nothing+    TraceEvent -> Nothing+    TraceUnsafeIo s -> case s of+      StdErrSink -> Nothing+      StdOutSink -> Nothing+      FileSink "" -> throwRefineOtherException (typeRep p) "Sink path is empty"+      FileSink _ -> Nothing
+ src/Debug/TraceEmbrace/Config/Type/TraceMessage.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+module Debug.TraceEmbrace.Config.Type.TraceMessage where++import Control.Applicative+import Control.Lens hiding (levels)+import Data.Aeson hiding (Error)+import Data.Generics.Labels ()+import Debug.TraceEmbrace.Config.Validation+import GHC.Generics+import Language.Haskell.TH.Syntax+import Refined++data TraceMessageElement+  = LiteralMessage -- ^ Constant tracing message+  | Variables -- ^ Variables e.g. @; x: 123; y: 321@+  | FullyQualifiedModule -- ^ Full Haskell module name (e.g. @Data.Map.Strict@)+  | ModuleName -- ^ Unqualified Haskell module name (e.g. @Strict@)+  | ShortenJavaModule -- ^ @D.M.Strict@+  | PackageName -- ^ Cabal package name+  | FunctionName -- ^ Function or method name containing tracing+  | LineNumber -- ^ Line number with tracing+  | Delimiter String -- | TraceMessageElement delimiter+  deriving (Eq, Show, Generic, Lift)++instance ToJSON TraceMessageElement where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON TraceMessageElement++data TraceMessageFormatG a+  = TraceMessageFormat+    { entrySeparator :: Columnar a SeparatorValidator String -- ^ @"; "@ is default+    , keyValueSeparator :: Columnar a SeparatorValidator String -- ^ @": "@ is default+    , retValPrefix :: Columnar a SeparatorValidator String -- ^ @" => "@+    , traceLinePattern :: Columnar a NonEmpty [TraceMessageElement]+    }++-- watch out for derivation order: https://gitlab.haskell.org/ghc/ghc/-/issues/25798+entrySeparator :: Lens' (TraceMessageFormatG a) (Columnar a SeparatorValidator String)+entrySeparator = lens (.entrySeparator) $ \x a -> x { entrySeparator = a }+keyValueSeparator :: Lens' (TraceMessageFormatG a) (Columnar a SeparatorValidator String)+keyValueSeparator = lens (.keyValueSeparator) $ \x a -> x { keyValueSeparator = a }+retValPrefix :: Lens' (TraceMessageFormatG a) (Columnar a SeparatorValidator String)+retValPrefix = lens (.retValPrefix) $ \x a -> x { retValPrefix = a }+traceLinePattern :: Lens' (TraceMessageFormatG a) (Columnar a NonEmpty [TraceMessageElement])+traceLinePattern = lens (.traceLinePattern) $ \x a -> x { traceLinePattern = a }++type TraceMessageFormat = TraceMessageFormatG Identity+type TraceMessageFormatMaybe = TraceMessageFormatG Maybe+++deriving instance Generic TraceMessageFormatMaybe+deriving instance Generic TraceMessageFormat+deriving instance Show TraceMessageFormat+deriving instance Eq TraceMessageFormat+instance ToJSON TraceMessageFormat where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON TraceMessageFormat+deriving instance Show TraceMessageFormatMaybe+deriving instance Eq TraceMessageFormatMaybe++instance ToJSON TraceMessageFormatMaybe where+  toEncoding = genericToEncoding defaultOptions+instance FromJSON TraceMessageFormatMaybe+instance Semigroup TraceMessageFormatMaybe where+  a <> b =+    TraceMessageFormat+    (a.entrySeparator <|> b.entrySeparator)+    (a.keyValueSeparator <|> b.keyValueSeparator)+    (a.retValPrefix <|> b.retValPrefix)+    (a.traceLinePattern <|> b.traceLinePattern)
+ src/Debug/TraceEmbrace/Config/Validation.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE PolyKinds #-}+module Debug.TraceEmbrace.Config.Validation where++import Data.Functor.Identity+import Refined+++type family Columnar f r a where+  Columnar Identity r a = Refined r a+  Columnar Maybe _ a = Maybe a++mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f = \case+  Left x -> Left $ f x+  Right o -> Right o++refineS :: forall {k} (p :: k) x. Predicate p x => String -> x -> Either String (Refined p x)+refineS fieldName =+  mapLeft ((("Field [" <> fieldName <> "] is not valid due: ") <>) . show) . refine++required :: forall {k} {p :: k} {a}. Predicate p a => String -> Maybe a -> Either String (Refined p a)+required s v =+  (maybe (Left $ "[" <> s <> "] field is required") pure v) >>= refineS s++type SeparatorValidator = And (SizeLessThan 5) NonEmpty
+ src/Debug/TraceEmbrace/FileIndex.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Index functions and methods of a Haskell module by line number+module Debug.TraceEmbrace.FileIndex where++import Data.IntMap.Strict qualified as IM+import Data.String+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.StringBuffer+import GHC.Driver.Config.Parser+import GHC.Driver.DynFlags+import GHC.Parser+import GHC.Parser.Annotation+import GHC.Parser.Lexer hiding (buffer)+import GHC.Tc.Types+import GHC.Types.Name hiding (Name)+import GHC.Types.Name.Reader+import GHC.Types.SrcLoc+import GHC.Utils.Outputable hiding ((<>))+import Language.Haskell.Syntax+import Language.Haskell.TH.Syntax (Q (..), runIO, getQ, putQ, Loc (..), Lift, reportWarning)+import Language.Preprocessor.Cpphs (runCpphs, defaultCpphsOptions)+import Unsafe.Coerce+++newtype FunName = FunName String deriving (Show, Eq, Ord, IsString, Lift)+type LineFileIndex = IM.IntMap FunName++unsafeRunTcM :: TcM a -> Q a+unsafeRunTcM m = Q (unsafeCoerce m)++instance HasDynFlags Q where+  getDynFlags = unsafeRunTcM getDynFlags++calret :: Monad m => (a -> m ()) -> a -> m a+calret f a = f a >> pure a++getLineFileIndex' :: FilePath -> Q LineFileIndex+getLineFileIndex' fp = getQ >>= maybe (calret putQ =<< mkLineFunIndex fp) pure++getLineFileIndex :: Loc -> Q LineFileIndex+getLineFileIndex = getLineFileIndex' . loc_filename++mkLineFunIndex :: FilePath -> Q LineFileIndex+mkLineFunIndex fp = do+  fileContent <- runIO (runCpphs defaultCpphsOptions fp =<< readFile fp)+  ops <- initParserOpts <$> getDynFlags+  case runParser fp ops fileContent parseModule of+    POk _ (L _ r) ->+      pure $ IM.fromList (concatMap extract (hsmodDecls r))+    PFailed ps -> do+      reportWarning $+        "Failed to parse [" <> fp <> "] for line function index due: " <>+        renderWithContext defaultSDocContext (ppr $ getPsErrorMessages ps) <>+        "\n--------------------------------------------------------------------"+      pure mempty+  where+    indexEntry EpAnn {entry} = \case+      L _ fi ->+        case fi of+          Unqual s ->+              [ ( srcLocLine (realSrcSpanStart (anchor entry))+                , FunName $ occNameString s+                )+              ]+          _ -> []++    methodExtract (L l (FunBind {fun_id})) = indexEntry l fun_id+    methodExtract _ = []++    extract (L l (ValD _ (FunBind {fun_id}))) = indexEntry l fun_id+    extract (L _ (InstD _ (ClsInstD {cid_inst}))) =+      case cid_inst of+        ClsInstDecl {cid_binds} -> concatMap methodExtract (bagToList cid_binds)+        _ -> []+    extract (L _ (TyClD _ (ClassDecl {tcdMeths}))) =+      concatMap methodExtract (bagToList tcdMeths)+    extract _ = []++runParser :: FilePath -> ParserOpts -> String -> P a -> ParseResult a+runParser filename opts str parser = unP parser parseState+  where+    location' = mkRealSrcLoc (mkFastString filename) 1 1+    buffer = stringToStringBuffer str+    parseState = initParserState opts buffer location'
+ src/Debug/TraceEmbrace/Haddock.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Alternative workaround to avoid unused warnings for+-- types and values referred only in HADDOCKS+module Debug.TraceEmbrace.Haddock (HaddockRefs (..), module E) where++import Data.Proxy as E+import Data.Tagged as E++class HaddockRefs a where+  usedSomeHow :: Proxy a -> Int
+ src/Debug/TraceEmbrace/Internal/Rewrap.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}++module Debug.TraceEmbrace.Internal.Rewrap where++import GHC.Exts++-- | Unlifted value wrapper to be squize throughout trace function+class Rewrap (t :: TYPE r) b | t -> b where+  wrap :: t -> b+  unwrap :: b -> t++instance Rewrap Int# Int where+  wrap = I#+  unwrap (I# x#) = x#++instance Rewrap Double# Double where+  wrap = D#+  unwrap (D# x#) = x#++instance Rewrap Float# Float where+  wrap = F#+  unwrap (F# x#) = x#++instance Rewrap Addr# (Ptr ()) where+  wrap = Ptr+  unwrap (Ptr x#) = x#++instance Rewrap Char# Char where+  wrap = C#+  unwrap (C# x#) = x#++instance Rewrap Word# Word where+  wrap = W#+  unwrap (W# x#) = x#++instance Rewrap a a where+  wrap = id+  unwrap = id
+ src/Debug/TraceEmbrace/Internal/TH.hs view
@@ -0,0 +1,367 @@+{-# OPTIONS_HADDOCK hide #-}+module Debug.TraceEmbrace.Internal.TH where++import Control.DeepSeq+import Control.Lens hiding (levels)+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Class qualified as MT+import Data.Char as C+import Data.IORef+import Data.Generics.Labels ()+import Data.Text qualified as T+import Data.IntMap.Strict qualified as IM+import Data.RadixTree.Word8.Strict qualified as T+import qualified Debug.Trace as T+import Debug.TraceEmbrace.Config+import Debug.TraceEmbrace.FileIndex+import Debug.TraceEmbrace.Internal.Rewrap+import Debug.TraceEmbrace.Show+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Prelude hiding (Show (..))+import Prelude qualified as P+import Refined+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import Text.Printf++newtype TrMsgAndVars = TrMsgAndVars String deriving (Eq, P.Show)+newtype VarsPart = VarsPart String deriving (Eq, P.Show)+newtype ModTraceFlagVarName = ModTraceFlagVarName Name deriving (Eq, P.Show)++type SVarsFunM a = StateT (Maybe Name) Q a+type SVarsFun = TraceMessageFormat -> VarsPart -> SVarsFunM Exp++showTrace :: Show (ShowTrace a) => a -> String+showTrace = show . ShowTrace++-- | Extract var names from a word.+--+-- @+-- "_" => []+-- "0" => []+-- "(Just" => []+-- "x@[a,_c]"=> ["x", "a"]+-- "l@(h:t)"  => ["l", "h", "t"]+-- "{a,b}"    => ["a", "b"]+-- @+--+varNamesFromPat :: String -> [String]+varNamesFromPat = filterVars . words . fmap replaceWithSpace . stripStrComment+  where+    filterVars = filter (\case { h:_ -> C.isLower h; [] -> False; })+    replaceWithSpace c+      | c `elem` ",!@({[:]})~" = ' '+      | otherwise = c++    dropTillEndOfString = \case+      "" -> ""+      '\\' : '"' : t -> dropTillEndOfString t+      '"' : t -> t+      _ : t -> dropTillEndOfString t++    dropTillEndOfLine = \case+      "" -> ""+      '\n' : t -> t+      _ : t -> dropTillEndOfLine t++    dropTillEndOfComment = \case+      "" -> ""+      '-' : '}' : t -> t+      '{' : '-' : t -> dropTillEndOfComment $ dropTillEndOfComment t+      _ : t -> dropTillEndOfComment t++    stripStrComment = \case+      "" -> ""+      '"' : t -> stripStrComment $ dropTillEndOfString t+      '-' : '-' : t -> stripStrComment $ dropTillEndOfLine t+      '{' : '-' : t -> stripStrComment $ dropTillEndOfComment t+      h : t -> h : stripStrComment t++{- | Interpolate vars in the arugment.+Generated expression has type 'String'.+The argument has literal and interpolated parts.+There parts are separated with right slash (/).++@+foo x y = trace $(svars "get/x y") x+@++The snippet above is expanded into:++@+foo x y = trace ("get; x: " <> show x <> "; y: " <> show y) x+@++'Show' instance of some types (eg lazy ByteString) hide+internal structure which might be important in low level code.+Variables after ";" are wrapped into t'ShowTrace':++@+import Data.ByteString.Lazy+foo x = trace $(svars "get/x;x") x+@++The snippet above is expanded into:++@+foo x = trace ("get; x: " <> show x <> "; x: " <> show (ShowTrace y)) x+@++-}+svars :: SVarsFun+svars tmf (VarsPart vars) = MT.lift $+  case span (';' /=) vars of+    (showVars, ';' : traceVars) ->+      [| $(listE (wordsToVars 'show showVars+                   <> wordsToVars 'showTrace traceVars)) :: [String] |]+    (showVars, "") ->+      [| $(listE (wordsToVars 'show showVars)) :: [String] |]+    (sv, st) -> do+      reportError $ printf "No case for %s %s" sv st+      [| [] |]+  where+    wordsToVars f vss = fmap go (varNamesFromPat vss)+      where+        go vs =+          lookupValueName vs >>= \case+            Nothing -> do+              reportError $ printf "no variable [%s]" vs+              [| $(lift vs) |]+            Just vn ->+              [| $(lift . unrefine $ tmf ^. #entrySeparator)+                 <> $(lift vs)+                 <> $(lift . unrefine $ tmf ^. #keyValueSeparator)+                 <> $(varE f) $(varE vn)+               |]++splitMessageFromVars :: TrMsgAndVars -> (String, VarsPart)+splitMessageFromVars (TrMsgAndVars trMsg) =+  case span ('/' /=) trMsg of+    (msgPart, '/':varPart) -> (msgPart, VarsPart varPart)+    (msgPart, []) -> (msgPart, VarsPart [])+    e ->  error $ "No case for:" <> show e++traceMessageLevel :: String -> (TraceLevel, TrMsgAndVars)+traceMessageLevel = fmap TrMsgAndVars . charToLevel++-- | Suffix 'svars' with return value.+svarsWith :: SVarsFun+svarsWith tmf vp =+  get >>= maybe (calret (put . Just) =<< MT.lift (newName "retVal")) pure >>= \retValVarName -> MT.lift $+  [| $(evalStateT (svars tmf vp) Nothing)+     <> [ $(lift . unrefine $ tmf ^. #retValPrefix)+        , show $(varE retValVarName)+        ]+     {- :: (Rewrap a b, Show a) => a -> [String] -}+   |]++concat2 :: Monoid m => [[m]] -> m+concat2 = mconcat . mconcat+{-# INLINE concat2 #-}++-- | Format whole trace message+traceMessage :: TrMsgAndVars -> TraceMessageFormat -> SVarsFun -> Q Exp+traceMessage mavs tmf svarsFun =+  runStateT itemExprs Nothing >>= \case+    (exprList, Nothing) ->+      [| concat2 $(pure $ ListE exprList) |]+    (exprList :: [Exp], Just retValVarName) ->+      [| \ $(varP retValVarName) -> concat2 $(pure $ ListE exprList) |]+  where+    itemExprs :: SVarsFunM [Exp]+    itemExprs = sequence (genItem <$> (unrefine (tmf ^. #traceLinePattern)))+    loc = MT.lift location+    strL = ListE . (:[]) . LitE . StringL+    pStrL = pure . strL+    genItem :: TraceMessageElement -> SVarsFunM Exp+    genItem = \case+      LiteralMessage -> pStrL . fst $ splitMessageFromVars mavs+      Variables -> svarsFun tmf . snd $ splitMessageFromVars mavs+      FullyQualifiedModule -> strL . loc_module <$> loc+      ModuleName ->+        strL . reverse . takeWhile (/= '.') . reverse . loc_module <$> loc+      ShortenJavaModule -> do+        (eludom, htap) <- span (/= '.') . reverse . loc_module <$> loc+        pStrL $ shortenModPath True (reverse htap) <> (reverse eludom)+      PackageName -> strL . loc_package <$> loc+      FunctionName -> do+        lc <- loc+        let+          m = loc_module lc+          line = fst $ loc_start lc+        strL <$> MT.lift (fmap snd . IM.lookupLE line <$> getLineFileIndex lc >>= \case+          Nothing -> do+            reportWarning (printf "No function name for line [%d] in module [%s]" line m)+            pure "N/A"+          Just (FunName fn) -> pure fn)+      LineNumber -> strL . P.show . fst . loc_start <$> loc+      Delimiter del -> pStrL del++shortenModPath :: Bool -> String -> String+shortenModPath prevDot+  | prevDot = \case+      c : r -> c : shortenModPath False r+      [] -> []+  | otherwise = \case+      '.' : r -> '.' : shortenModPath True r+      _ : r -> shortenModPath False r+      [] -> []++flagVarName :: Q Name+flagVarName =+  newName =<< ("_trace_if_flag_on_line_" <>) . show . fst . loc_start <$> location++getModTraceFlagVar :: Q Name+getModTraceFlagVar = do+  vn <- flagVarName+  putQ (ModTraceFlagVarName vn)+  nothingRefT <- [t| IORef (Maybe Bool) |]+  nothingRef <- [| unsafePerformIO (newIORef Nothing) |]+  addTopDecls+    [ SigD vn nothingRefT+    , ValD (VarP vn) (NormalB nothingRef) []+    , PragmaD (InlineP vn NoInline ConLike AllPhases)+    ]+  pure vn++isLevelOverThreshold :: T.Lookup TraceLevel -> TraceLevel -> Bool+isLevelOverThreshold (T.Lookup _ levelThreshold) tl = levelThreshold <= tl+{-# INLINE isLevelOverThreshold #-}++-- | Eval level and cache+readTraceFlag ::  T.Text -> TraceLevel -> DynConfigEnvVar -> IORef (Maybe Bool) -> IO Bool+readTraceFlag modName trLvl evar fv = do+  readIORef fv >>= \case+    Just r -> pure r+    Nothing -> do+      T.lookupL T.Open (T.feedText modName) <$> getRuntimeConfig evar >>= \case+        Just threshold ->+          let !r = isLevelOverThreshold threshold trLvl in+            atomicWriteIORef fv (Just r) >> pure r+        Nothing ->+          atomicWriteIORef fv (Just False) >> pure False+{-# INLINE readTraceFlag #-}++traceG :: TraceEmbraceConfig -> Q Exp -> (TrMsgAndVars -> TraceMessageFormat -> Q Exp) -> String -> Q Exp+traceG c idF genTraceLine s =+  case c ^. #mode of+    TraceDisabled -> idF+    TraceStd -> go+    TraceUnsafeIo _ -> go+    TraceEvent -> go+  where+    go =+      case traceMessageLevel s of+        (TracingDisabled, _) -> idF+        (tl, s') -> do+          loc <- location+          let modName = T.pack $ loc_module loc+          case T.lookupL T.Open (T.feedText modName) $ c ^. #levels of+            Nothing -> idF+            Just threshold+              | isLevelOverThreshold threshold tl ->+                case envVarName loc (c ^. #runtimeLevelsOverrideEnvVar) of+                  Just evar -> do+                    vn <- getModTraceFlagVar+                    [| case unsafePerformIO (readTraceFlag modName tl evar $(varE vn)) of+                         True -> $(genTraceLine s' $ c ^. #traceMessage)+                         False -> $(idF)+                     |]+                  Nothing -> genTraceLine s' $ c ^. #traceMessage+              | otherwise -> idF++unsafePutStrLn :: IoSink -> String -> a -> a+unsafePutStrLn s msg v =+  msg `deepseq` (unsafePerformIO (hPutStrLn (getSinkHandle s) msg)) `seq` v+  where+{-# NOINLINE unsafePutStrLn #-}++getSinkHandle :: IoSink -> Handle+getSinkHandle s =+  case s of+    StdErrSink -> stderr+    StdOutSink -> stdout+    FileSink fp -> unsafePerformIO $ do+      readIORef unsafeIoSink >>= \case+        Just h -> pure h+        Nothing -> do+          nh <- openFile fp AppendMode+          (atomicModifyIORef' unsafeIoSink $ \case+            Nothing -> (Just nh, (False, nh))+            Just oh -> (Just oh, (True, oh))) >>= \case+               (True, h) ->  hClose nh >> pure h+               (False, h) -> pure h++safePutStrLn :: IoSink -> String -> a -> IO a+safePutStrLn s msg v =+  hPutStrLn (getSinkHandle s) msg >> pure v++chooseTraceFunOnTh :: Show s => TraceEmbraceConfig -> s -> Q Exp+chooseTraceFunOnTh c s =+  case c ^. #mode of+    TraceDisabled -> fail $ "Dead code on" <> show s+    TraceStd -> pure $ VarE 'T.trace+    TraceUnsafeIo snk -> [| unsafePutStrLn snk |]+    TraceEvent -> pure $ VarE 'T.traceEvent++tr :: Q Exp -> String -> Q Exp+tr idF rawMsg = do+  c <- getConfig+  traceG c idF (go c) rawMsg+  where+    go c s fmt =+      [| \x -> unwrap ($(chooseTraceFunOnTh c s) $(traceMessage s fmt svars) (wrap x)) |]++tw :: Q Exp -> String -> Q Exp+tw idF rawMsg = do+  c <- getConfig+  traceG c idF (go c) rawMsg+  where+    go c s fmt =+      [| \x -> unwrap ($(chooseTraceFunOnTh c s)+                        ($(traceMessage s fmt svarsWith) x)+                        (wrap x))+       |]++tw' :: Q Exp -> String -> Q Exp+tw' idF rawMsg = do+  c <- getConfig+  traceG c idF (go c) rawMsg+  where+    go c s fmt =+      [| \x -> unwrap ($(chooseTraceFunOnTh c s)+                        ($(traceMessage s fmt svarsWith) (ShowTrace x))+                        (wrap x))+       |]++trIo :: Q Exp -> String -> Q Exp+trIo idF rawMsg = do+  c <- getConfig+  traceG c idF (go c) rawMsg+  where+    go c s fmt = do+      let trFun = case c ^. #mode of+                    TraceDisabled -> error $ "Dead code on" <> show s+                    TraceStd -> 'T.traceIO+                    TraceUnsafeIo _ -> 'safePutStrLn+                    TraceEvent -> 'T.traceEventIO+      [| $(varE trFun) $(traceMessage s fmt svars) |]++trFunMarker :: Q Exp -> Q Exp+trFunMarker idF = do+  c <- getConfig+  let finalC = if c ^. #mode == TraceDisabled then c else markerConfig+  traceG finalC idF go "/"+  where+    go s fmt =+      [| \x -> unwrap (T.traceMarker $(traceMessage s fmt svars) (wrap x)) |]++trIoFunMarker :: Q Exp -> Q Exp+trIoFunMarker idF = do+  c <- getConfig+  let finalC = if c ^. #mode == TraceDisabled then c else markerConfig+  traceG finalC idF go "/"+  where+    go s fmt =+      [| T.traceMarkerIO $(traceMessage s fmt svars) |]
+ src/Debug/TraceEmbrace/Show.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | More detailed Show for debugging+-- E.g. show instance of lazy ByteString hides how many+-- chunks in the string.+module Debug.TraceEmbrace.Show (module STh, module B) where++import Debug.TraceEmbrace.ByteString as B+import Debug.TraceEmbrace.ShowTh as STh+import GHC.Exts+import Prelude hiding (Show (..))+import Prelude qualified as P++instance Show Int# where+  show i# = P.show (I# i#) <> "#"++instance Show Float# where+  show i# = P.show (F# i#) <> "#"++instance Show Char# where+  show i# = P.show (C# i#) <> "#"++instance Show Word# where+  show i# = P.show (W# i#) <> "#"++instance Show Double# where+  show i# = P.show (D# i#) <> "#"++instance Show Addr# where+  show i# = P.show (Ptr @() i#) <> "#"++instance Show (# #) where+  show _ = "(# #)"++instance (Show a#) => Show (# a# #) where+  show (# a# #) = "(# " <> show a# <> " #)"++$(let utypes = [''Int#, ''Char#, ''Double#, ''Float#, ''Addr#]+   in concat <$> sequence [ deriveShowTuple1 ut | ut <- utypes ])++instance (Show a, Show b) => Show (# a, b #) where+  show (# a#, b# #) = "(# " <> show a# <> ", " <> show b# <> " #)"++$(concat <$> sequence [ deriveShowTuple2 ut ut' | ut <- unTypes, ut' <- unTypes ])+$(concat <$> sequence [ deriveShowSum2 ut ut' | ut <- unTypes, ut' <- unTypes ])++instance (Show a, Show b, Show c) => Show (# a, b, c #) where+  show (# a, b, c #) = "(# " <> show a <> ", " <> show b <> ", " <> show c <> " #)"++$(concat <$> sequence [ deriveShowTuple3 ut ut' ut'' | ut <- unTypes, ut' <- unTypes, ut'' <- unTypes ])+$(concat <$> sequence [ deriveShowSum3 ut ut' ut'' | ut <- unTypes, ut' <- unTypes, ut'' <- unTypes ])++instance {-# OVERLAPPABLE #-} P.Show a => Show a where+  show = P.show
+ src/Debug/TraceEmbrace/ShowTh.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedNewtypes #-}++module Debug.TraceEmbrace.ShowTh where++import GHC.Exts+import Language.Haskell.TH+import Prelude hiding (Show (..))++-- | Levity polymorphic version 'P.Show'.+class Show (t :: TYPE r) where+  show :: t -> String++-- | https://gitlab.haskell.org/ghc/ghc/-/issues/25776+deriveShowTuple1 :: Name -> Q [Dec]+deriveShowTuple1 a = [d|+  instance Show (# $(conT a) #) where+    show (# a# #) = "(# " <> show a# <> " #)"+  |]++deriveShowTuple2 :: Name -> Name -> Q [Dec]+deriveShowTuple2 a b = [d|+  instance Show (# $(conT a), $(conT b) #) where+    show (# a#, b# #) = "(# " <> show a# <> ", " <> show b# <> " #)"+  |]++deriveShowTuple3 :: Name -> Name -> Name -> Q [Dec]+deriveShowTuple3 a b c = [d|+  instance Show (# $(conT a), $(conT b), $(conT c) #) where+    show (# a#, b#, c# #) = "(# " <> show a# <> ", " <> show b# <> ", " <> show c# <> " #)"+  |]++deriveShowTuple4 :: Name -> Name -> Name -> Name -> Q [Dec]+deriveShowTuple4 a b c d = [d|+  instance Show (# $(conT a), $(conT b), $(conT c), $(conT d) #) where+    show (# a#, b#, c#, d# #) = "(# " <> show a# <> ", " <> show b# <> ", " <> show c# <> ", " <> show d# <> " #)"+  |]++deriveShowSum2 :: Name -> Name -> Q [Dec]+deriveShowSum2 a b = [d|+  instance Show (# $(conT a) | $(conT b) #) where+    show (# a# | #) = "(# " <> show a# <> " | #)"+    show (# | b# #) = "(# | " <> show b# <> " #)"+  |]++deriveShowSum3 :: Name -> Name -> Name -> Q [Dec]+deriveShowSum3 a b c = [d|+  instance Show (# $(conT a) | $(conT b) | $(conT c) #) where+    show (# x# | | #) = "(# " <> show x# <> " | | #)"+    show (# | x# | #) = "(# | " <> show x# <> " | #)"+    show (# | | x# #) = "(# | | " <> show x# <> " #)"+  |]++deriveShowSum4 :: Name -> Name -> Name -> Name -> Q [Dec]+deriveShowSum4 a b c d = [d|+  instance Show (# $(conT a) | $(conT b) | $(conT c) | $(conT d) #) where+    show (# x# | | | #) = "(# " <> show x# <> " | | | #)"+    show (# | x# | | #) = "(# | " <> show x# <> " | | #)"+    show (# | | x# | #) = "(# | | " <> show x# <> " | #)"+    show (# | | | x# #) = "(# | | | " <> show x# <> " #)"+  |]++unTypes :: [Name]+unTypes = [''Int#, ''Char#, ''Double#, ''Float#, ''Addr#]
+ src/Debug/TraceEmbrace/TH.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_HADDOCK hide, prune #-}++-- | Tracing with TH+module Debug.TraceEmbrace.TH (tr, tw, tw', trIo, trFunMarker, trIoFunMarker) where++import Debug.Trace+import Debug.TraceEmbrace.Config+import Debug.TraceEmbrace.Haddock+import Debug.TraceEmbrace.Internal.Rewrap+import Debug.TraceEmbrace.Internal.TH qualified as I+import Language.Haskell.TH++data Ref++instance HaddockRefs Ref where+  usedSomeHow _ = length ['TraceMessageFormat, ''Rewrap, 'trace, 'traceEvent]++-- | TH version of 'trace' and 'traceEvent'+-- The message is formatted according to 'TraceMessageFormat'.+-- The generated expression has type @forall r (a :: TYPE r) b a. 'Rewrap' a b => a -> a@.+-- 'id' is generated if effective trace level is lower than trace level threshold.+-- Example:+--+-- > foo x = $(tr "get/x") x+--+-- Output:+--+-- > Module::foo get; x : 132+tr :: String -> Q Exp+tr = I.tr [| \x -> x |]+++-- | TH version of 'traceWith' and 'traceEventWith'+-- The message is formatted according to 'TraceMessageFormat'.+-- The generated expression has type @forall r (a :: TYPE r) b a. (Show a, Rewrap a b) => a -> a@.+-- 'id' is generated if effective trace level is lower than trace level threshold.+-- Example:+--+-- > foo x = $(tw "get/x") (x + 1)+--+-- Output:+--+-- > Module::foo get; x : 132 => 133+tw :: String -> Q Exp+tw = I.tw [| \x -> x |]++-- | Like 'tw' but return value is wrapped with 'ShowTrace'.+tw' :: String -> Q Exp+tw' = I.tw' [| \x -> x |]++-- | TH version of 'traceIO' and 'traceEventIO'+-- The message is formatted according to 'TraceMessageFormat'.+-- Example:+--+-- > foo x = $(trIo "get/x") >> pure x+--+-- Output:+--+-- > Module::foo get; x : 132+trIo :: String -> Q Exp+trIo = I.trIo [| pure () |]++-- | TH version of 'traceMarker' where module and function+-- are used as a marker. Trace level is used.+trFunMarker :: Q Exp+trFunMarker = I.trFunMarker [| \x -> x |]++-- | TH version of 'traceMarkerIO' where module and function+-- are used as a marker. Trace level is not used.+trIoFunMarker :: Q Exp+trIoFunMarker = I.trIoFunMarker [| pure () |]
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/Config.hs view
@@ -0,0 +1,107 @@+module Debug.TraceEmbrace.Test.TraceEmbrace.Config where++import Control.Concurrent.MVar+import Control.Exception+import Control.Lens+import Control.Monad+import Data.Cache.LRU+import Data.Generics.Labels ()+import Data.IORef+import Data.Maybe+import Debug.TraceEmbrace.Config+import Debug.TraceEmbrace.Internal.TH+import Language.Haskell.TH.Syntax+import Refined+import System.Directory+import System.Environment+import System.IO+import System.IO.Temp++positionOnly :: TraceMessageFormat+positionOnly =+  defaultTraceMessageFormat+  { traceLinePattern = $$(refineTH+                          [ FullyQualifiedModule+                          , Delimiter "::"+                          , FunctionName+                          ])+                       :: Refined NonEmpty [TraceMessageElement]+  }++lineOnly :: TraceMessageFormat+lineOnly =+  defaultTraceMessageFormat+  { traceLinePattern = $$(refineTH+    [ LineNumber+    , Delimiter ":"+    ]) :: Refined NonEmpty [TraceMessageElement]+  }++msgAndVarsOnly :: TraceMessageFormat+msgAndVarsOnly =+  defaultTraceMessageFormat+  { traceLinePattern =+      $$(refineTH [ LiteralMessage, Variables ]) ::+      Refined NonEmpty [TraceMessageElement]+  }++trConstMsg :: String -> Q Exp+trConstMsg msgAndVars = traceMessage (TrMsgAndVars msgAndVars) msgAndVarsOnly svars++trFunMsg :: String -> Q Exp+trFunMsg msgAndVars = traceMessage (TrMsgAndVars msgAndVars) msgAndVarsOnly svarsWith++one :: Int+one = 1++two :: Int+two = 2++thresholdConfig :: TraceEmbraceConfig+thresholdConfig = v & #levels .~ mkPrefixTree (emptyPrefixTraceLevel Info)+ where+   v :: TraceEmbraceConfig+   v = case (yaml2Config <$> validateYamlConfig newYamlConfig) of+         Right r -> r+         Left e -> error e++setConfig :: TraceEmbraceConfig -> Q ()+setConfig c =+  runIO (do closeUnsafeIoSink+            atomicWriteIORef traceEmbraceConfigRef (Just c))++closeUnsafeIoSink :: IO ()+closeUnsafeIoSink = do+  atomicModifyIORef' unsafeIoSink (\x -> (Nothing, x)) >>= \case+    Nothing -> pure ()+    Just h -> hClose h++withEnv :: String -> String -> IO a -> IO a+withEnv evar val a = do+  oldVal <- lookupEnv evar+  bracket (setEnv evar val)+          (\_ -> setEnv evar $ fromMaybe "" oldVal)+          (\_ -> a)++withPrefixEnvVar :: TraceEmbraceConfig -> String -> IO a -> IO a+withPrefixEnvVar c val a =+  case c ^. #runtimeLevelsOverrideEnvVar of+    Ignored -> fail "Env var is ignored"+    CapsPackageName ->+      go $ packageBasedEnvVarPrefix <> "TRACE_EMBRACE"+    EnvironmentVariable ev -> go ev+  where+    go ev =+      withEnv ev val $ do+        modifyMVar_ runtimeTraceEmbraceConfigRef (\_ -> pure . newLRU $ Just 7)+        a++poisonedId :: Q Exp+poisonedId = [| \x -> x + 1 |]++fileSynkTmp :: FilePath+fileSynkTmp =+  $(LitE . StringL <$> (runIO (do+                                  f <- emptySystemTempFile "unsafeIoSinkFile.log"+                                  doesFileExist f >>= flip when (removeFile f)+                                  pure f)))
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/DemoIndex.hs view
@@ -0,0 +1,8 @@+module Debug.TraceEmbrace.Test.TraceEmbrace.DemoIndex where++import Data.IntMap.Strict qualified as IM+import Debug.TraceEmbrace.FileIndex+import Language.Haskell.TH.Syntax++demoIndex :: IM.IntMap FunName+demoIndex = $(lift =<< getLineFileIndex' =<< (<> "/test/Demo.hs") <$> qGetPackageRoot)
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/FileIndex.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.FileIndex where++import Data.IntMap.Strict qualified as IM+import Debug.TraceEmbrace.Test.TraceEmbrace.DemoIndex+import Test.Tasty.HUnit ((@=?))++unit_fileindex :: IO ()+unit_fileindex = IM.fromList l @=? demoIndex+  where+    l = [(12,"***"),(17,"show"),(23,"mylen"),(26,"+++"),(27,"mylen"),(30,"foo")]
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.TH where++import Data.ByteString.Lazy+import Debug.TraceEmbrace+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Test.Tasty.HUnit ((@=?))++unit_tr_trace :: IO ()+unit_tr_trace = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+      where+        foo = $(tr "-foo trace/x")++unit_tr_info :: IO ()+unit_tr_info = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+      where+        foo = $(tr "foo info/x")++unit_tr_warning :: IO ()+unit_tr_warning = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+      where+        foo = $(tr "!foo warning/x")++unit_tr_error :: IO ()+unit_tr_error = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+      where+        foo = $(tr "|foo error/x")++unit_tw :: IO ()+unit_tw = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+    foo x = $(tw "tw foo/x") x++unit_tw' :: IO ()+unit_tw' = withPrefixEnvVar thresholdConfig "" $ go bs+  where+    bs :: ByteString = "x" <> "y"+    go x = x @=? foo x+    foo x = $(tw' "tw foo/x") x++unit_trIo :: IO ()+unit_trIo = withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = (x @=?) =<< foo x+      where+        foo y = $(trIo "foo info/y") >> pure y
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Event.hs view
@@ -0,0 +1,59 @@+module Debug.TraceEmbrace.Test.TraceEmbrace.TH.Event where++import Control.Exception+import Control.Lens+import Debug.TraceEmbrace.Config.Type+import Debug.TraceEmbrace.Internal.TH+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Test.Tasty.HUnit ((@=?))+import System.Directory++unit_unsafeio_stderr_mode :: IO ()+unit_unsafeio_stderr_mode =+  withPrefixEnvVar thresholdConfig "" $ do+    one @=? $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo StdErrSink))+              >> tr poisonedId "tm") one++unit_unsafeio_stdout_mode :: IO ()+unit_unsafeio_stdout_mode =+  withPrefixEnvVar thresholdConfig "" $ do+    one @=? $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo StdOutSink))+              >> tr poisonedId "tm") one++unit_unsafeio_filesink_mode :: IO ()+unit_unsafeio_filesink_mode =+  withPrefixEnvVar thresholdConfig "" $ do+    one @=? $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo $ FileSink fileSynkTmp))+              >> tr poisonedId "tm") one+    closeUnsafeIoSink+    finally+      (("Debug.TraceEmbrace.Test.TraceEmbrace.TH.Event::unit_unsafeio_filesink_mode: tm\n" @=?) =<< readFile fileSynkTmp)+      (removeFile fileSynkTmp)++unit_event_mode :: IO ()+unit_event_mode =+  withPrefixEnvVar thresholdConfig "" $ do+    one @=? $(setConfig (thresholdConfig & #mode .~ TraceEvent)+              >> tr poisonedId "tm") one++unit_event_trIo :: IO ()+unit_event_trIo =  withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = (x @=?) =<< foo x+      where+        foo y = $(setConfig (thresholdConfig & #mode .~ TraceEvent)+                  >> trIo [| pure () |] "foo/y") >> pure y++unit_marker_io :: IO ()+unit_marker_io =  withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = (x @=?) =<< foo x+      where+        foo y = $(trIoFunMarker [| pure () |]) >> pure y++unit_fun_marker :: IO ()+unit_fun_marker =  withPrefixEnvVar thresholdConfig "" $ go one+  where+    go x = x @=? foo x+      where+        foo = $(trFunMarker poisonedId)
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Format/Lifted.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Lifted where++import Data.ByteString.Lazy+import Debug.TraceEmbrace.Internal.TH+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Test.Tasty.HUnit ((@=?))++-- not working: https://gitlab.haskell.org/ghc/ghc/-/issues/25775+default (Int)++unit_traceMessage_const :: IO ()+unit_traceMessage_const =+  ("Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Lifted::unit_traceMessage_const" :: String) @=?+     $(traceMessage (TrMsgAndVars "skipped") positionOnly svars)++unit_traceMessage_fun :: IO ()+unit_traceMessage_fun = ("foo => True" :: String) @=?  $(trFunMsg "foo") True++unit_svarsWith :: IO ()+unit_svarsWith =+  let x = one in+    "bye; x: 1 => 2" @=? $(trFunMsg "bye/x") two++unit_let_x :: IO ()+unit_let_x = "bye; one: 1" @=? $(trConstMsg "bye/one")++unit_where_x :: IO ()+unit_where_x = "bye; x: 1" @=? $(trConstMsg "bye/x")+  where+    x = one++unit_string :: IO ()+unit_string = "bye; x: \"abc\"" @=? $(trConstMsg "bye/x")+  where+    x = "abc" :: String++unit_show_trace :: IO ()+unit_show_trace = "; x: [\"ab\",\"c\"]" @=? $(trConstMsg "/;x")+  where+    x = ("ab" <> "c") :: ByteString++unit_show_and_show_trace :: IO ()+unit_show_and_show_trace = "; y: True; x: [\"ab\",\"c\"]" @=? $(trConstMsg "/y;x")+  where+    x = ("ab" <> "c") :: ByteString+    y = True++unit_show_2_vars :: IO ()+unit_show_2_vars = "; y: True; x: \"abc\"" @=? $(trConstMsg "/y x")+  where+    x = ("ab" <> "c") :: ByteString+    y = True++unit_ignore_parenthesis_and_undebar :: IO ()+unit_ignore_parenthesis_and_undebar = "foo; x: 1" @=? foo (one, two)+  where+    foo (x, _) = $(trConstMsg "foo/(x, _)")++unit_empty_var_list :: IO ()+unit_empty_var_list = "hello" @=? $(trConstMsg "hello/")++unit_ignore_single_line_comment :: IO ()+unit_ignore_single_line_comment = "foo; x: 1" @=? foo one+  where+    foo x -- hello+      = $(trConstMsg "foo/x -- hello")++unit_ignore_string :: IO ()+unit_ignore_string = "foo; x: 1" @=? foo ("y y" :: String) one ("z" :: String)+  where+    foo "y y" x "z" = $(trConstMsg "foo/\"y y\" x \"z\" =")+    foo a _ c = "dead code due: " <> show (a, c)++unit_ignore_comment :: IO ()+unit_ignore_comment = "foo; x: 1" @=? foo one+  where+    foo {- comment before -} x {-after-} =+      $(trConstMsg "foo/{- comment before -} x {-after-}")++unit_ignore_bang :: IO ()+unit_ignore_bang = "foo; x: 1" @=? foo one+  where+    foo !x = $(trConstMsg "foo/!x")++unit_at :: IO ()+unit_at = "foo; x: Just 1; y: 1" @=? foo (Just one)+  where+    foo x@(Just y) = $(trConstMsg "foo/x@(Just y)")+    foo r = fail $ show r++data Point = Point { xPoint :: Int, yPoint :: Int } deriving Show++unit_record :: IO ()+unit_record = "foo; xPoint: 12" @=? foo (Point one two)+  where+    foo Point {xPoint,..} = $(trConstMsg "foo/Point {xPoint,..}") <> show yPoint++unit_record2 :: IO ()+unit_record2 = "foo; xPoint: 12" @=? foo (Point one two)+  where+    foo Point { xPoint, ..} = $(trConstMsg "foo/Point { xPoint, ..}") <> show yPoint++unit_list_int :: IO ()+unit_list_int = "foo; a: 1" @=? foo [one, two, 123]+  where+    foo [a, _b, 123] = $(trConstMsg "foo/[a, _b, 123]")+    foo r = fail $ show r++unit_char :: IO ()+unit_char = "foo; l: \"b\"" @=? foo "ab"+  where+    foo ('a':l) = $(trConstMsg "foo/('a':l)")+    foo r = fail $ show r
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Format/Unboxed.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}++module Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Unboxed where++import Control.Lens+import Data.Generics.Labels ()+import Debug.TraceEmbrace+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import GHC.Exts+import Test.Tasty.HUnit ((@=?))++unit_unboxed_int :: IO ()+unit_unboxed_int = "foo; x#: 1#" @=? foo one+  where+    foo (I# x#) = $(trConstMsg "foo/(I# x#)")++unit_ret_unboxed_int :: IO ()+unit_ret_unboxed_int = "foo; x#: 1# => 1#" @=? foo one+  where+    foo (I# x#) = $(trFunMsg "foo/(I# x#)") x#++unit_traceWith_unboxed_int :: IO ()+unit_traceWith_unboxed_int = one @=? foo one+  where+    foo (I# x#) = (I# ($(tw "foo/(I# x#)") x#))++unit_trace_ret_unboxed_int :: IO ()+unit_trace_ret_unboxed_int = one @=? foo one+  where+    foo (I# x#) = (I# ($(tr "foo/(I# x#)") x#))++unit_unboxed_tuple :: IO ()+unit_unboxed_tuple = expec @=? foo (# 1#, 2# #)+  where+    expec :: String = "foo; t: (# 1#, 2# #) => 1#"+    foo :: (# Int#, Int# #) -> String+    foo t@(# x#, _ #) = $(trFunMsg "foo/t") x#++prop_ret_unboxed_tuple :: Bool+prop_ret_unboxed_tuple = isTrue# (1# ==# foo t)+  where+    t = (# 1#, 2# #)+    foo :: (# Int#, Int# #) -> Int#+    foo tt@(# x#, _ #) =+      $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo StdErrSink)) >> tw "foo/tt") x#++prop_ret_unboxed_sum :: Bool+prop_ret_unboxed_sum = isTrue# $ 1# ==# foo (# 1# | #)+  where+    foo :: (# Int# | Double# #) -> Int#+    foo tt@(# x# | #) =+      $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo StdErrSink)) >> tw "foo/tt") x#+    foo tt@(# | _ #) =+      $(setConfig (thresholdConfig & #mode .~ (TraceUnsafeIo StdErrSink)) >> tw "foo/tt") 0#++unit_ret_unboxed_unit :: IO ()+unit_ret_unboxed_unit = "foo; t: (# #)" @=? foo (#  #)+  where+    foo :: (# #) -> String+    foo t = $(trConstMsg "foo/t")
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Line.hs view
@@ -0,0 +1,11 @@+-- | line number often changes which breaks test+-- So the test is isolated from others+module Debug.TraceEmbrace.Test.TraceEmbrace.TH.Line where++import Debug.TraceEmbrace.Internal.TH+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import Test.Tasty.HUnit ((@=?))++unit_traceMessage_line :: IO ()+unit_traceMessage_line =+  ("11:" :: String) @=? $(traceMessage (TrMsgAndVars "skipped") lineOnly svars)
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/TH/Threshold.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedRecordDot #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.TH.Threshold where++import Control.Lens+import Data.Generics.Labels ()+import Data.Yaml qualified as Y+import Debug.TraceEmbrace.Internal.TH qualified as I+import Debug.TraceEmbrace.Config+import Debug.TraceEmbrace.Test.TraceEmbrace.Config+import System.FilePath+import System.IO.Temp+import Test.Tasty.HUnit ((@=?))+++unit_mode_disabled :: IO ()+unit_mode_disabled =+  withPrefixEnvVar thresholdConfig "" $ do+    two @=? $(setConfig (thresholdConfig & #mode .~ TraceDisabled)+              >> I.tr poisonedId "tm") one++unit_mode_enabled_with_evar_unset :: IO ()+unit_mode_enabled_with_evar_unset =+  withPrefixEnvVar thresholdConfig "" $ do+    one @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+              >> I.tr poisonedId "tm") one++unit_mode_enabled_with_evar_unset_trace_level :: IO ()+unit_mode_enabled_with_evar_unset_trace_level =+  withPrefixEnvVar thresholdConfig "" $ do+    two @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+              >> I.tr poisonedId "-tm") one++unit_mode_enabled_with_runtime_threshold_level_too_high :: IO ()+unit_mode_enabled_with_runtime_threshold_level_too_high =+  withSystemTempDirectory "trace-embrace" $ \d ->+    let fp = d </> "runtime-conf.yaml" in do+      Y.encodeFile fp (emptyPrefixTraceLevel Error)+      withPrefixEnvVar thresholdConfig fp $ do+        two @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+                  >> I.tr poisonedId "tm") one++unit_mode_enabled_with_runtime_threshold_level_ok :: IO ()+unit_mode_enabled_with_runtime_threshold_level_ok =+  withSystemTempDirectory "trace-embrace" $ \d ->+    let fp = d </> "runtime-conf.yaml" in do+      Y.encodeFile fp (emptyPrefixTraceLevel Error)+      withPrefixEnvVar thresholdConfig fp $ do+        one @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+                  >> I.tr poisonedId "|tm") one++unit_runtime_cannot_lower_threshold_level :: IO ()+unit_runtime_cannot_lower_threshold_level =+  withSystemTempDirectory "trace-embrace" $ \d ->+    let fp = d </> "runtime-conf.yaml" in do+      Y.encodeFile fp (emptyPrefixTraceLevel Trace)+      withPrefixEnvVar thresholdConfig fp $ do+        two @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+                  >> I.tr poisonedId "-tm") one++unit_mode_enabled_with_evar_set_empty :: IO ()+unit_mode_enabled_with_evar_set_empty = do+  withPrefixEnvVar thresholdConfig "-" $ do+    two @=? $(setConfig (thresholdConfig & #mode .~ TraceStd)+              >> I.tr [| \x -> x + 1 |] "tm") one
+ test/Debug/TraceEmbrace/Test/TraceEmbrace/Yaml.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+module Debug.TraceEmbrace.Test.TraceEmbrace.Yaml where++import Data.Text+import Data.Yaml as Y+import Debug.TraceEmbrace.Config.Type.Level+import Test.Tasty.HUnit ((@=?))+import Test.Tasty.QuickCheck++instance Arbitrary TraceLevel where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary Text where+  arbitrary = pack . getUnicodeString <$> arbitrary++prop_dyn_conf_marshalling :: TraceLevel -> Text -> Bool+prop_dyn_conf_marshalling l t =+  case Y.decodeEither' (Y.encode e) of+    Left err -> error $ show err+    Right e' -> e' == e+  where+    e = LeveledModulePrefix l t++unit_dyn_conf_golden :: IO ()+unit_dyn_conf_golden = Y.encode l @=? "- '|Data'\n- '!Control'\n- System.\n- -Unsafe\n"+  where+    l = [ LeveledModulePrefix Error "Data"+        , LeveledModulePrefix Warning "Control"+        , LeveledModulePrefix Info "System."+        , LeveledModulePrefix Trace "Unsafe"+        ]
+ test/Demo.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE CPP #-}+-- | File combines samples which are important for FileIndex+-- such us top functions, method instances and default methods+module Demo where++#if !MIN_VERSION_base(4,8,0)+#endif+++(***) :: Int -> Int -> Int+x *** y = x * y++data X = X++instance Show X where+  show _ = "X"++class MyLen x where+  (+++) :: x -> x -> Int+  mylen :: x -> Int+  default mylen :: Show x => x -> Int+  mylen = length . show++instance MyLen Int where+  x +++ y = x + y+  mylen = id++foo :: Int -> Int+foo x = y+  where+    y = x
+ test/Discovery.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-}
+ test/Driver.hs view
@@ -0,0 +1,12 @@+module Driver where++import qualified Discovery+import Test.Tasty++main :: IO ()+main = defaultMain =<< testTree+  where+    testTree :: IO TestTree+    testTree = do+      tests <- Discovery.tests+      pure $ testGroup "trace-embrace" [ tests ]
+ trace-embrace.cabal view
@@ -0,0 +1,451 @@+cabal-version:   3.0+name:            trace-embrace+version:         1.0.2+license:         BSD-3-Clause+license-file:    LICENSE+category:        Development+author:          Daniil Iaitskov <dyaitskov@gmail.com>+maintainer:      Daniil Iaitskov <dyaitskov@gmail.com>+stability:       experimental+synopsis:        Compile and runtime configurable version of Debug.Trace module+homepage:        https://github.com/yaitskov/trace-embrace+bug-reports:     https://github.com/yaitskov/trace-embrace/issues+build-type:      Simple+description:+    +    Writing tracing code is very boring activity, especially in Haskell. The+    <https://hackage.haskell.org/package/trace-embrace trace-embrace>+    package minimizes the hassle of writing traces and maintaining them in+    codebase. Thanks to TH-driven DSL whole chunks of code containing+    function arguments could be quickly copy-pasted for tracing without+    massaging in a text editor.+    +    There are several issues with functions from standand GHC module+    <https://hackage.haskell.org/package/base/docs/Debug-Trace.html Debug.Trace>:+    +    -   no trace emitting location+    -   tracing expressions solicit to write lot of boilerplate code+    -   not possible to disable tracing without recompilation+    -   tracing is coupled with optimizaiton flag+    -   no per module granularity - all trace messages are disabled all at+        once+    +    Let’s look how trace-embrace deals with these issues.+    +    == Location+    #location#+    +    TH macros with help of GHC lib, besides the module and the line of+    exrpession emitting a trace message, find function or method name where+    the expression is.+    +    The trace message format is customizable through a config file+    (@trace-embrace.yaml@) located next to a cabal one, which is+    automatically generated if it is missing at build time. The trace line+    pattern can include location related fields such as+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:PackageName PackageName>,+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:FullyQualifiedModule FullyQualifiedModule>,+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:ModuleName ModuleName>,+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:FunctionName FunctionName>,+    and+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:LineNumber LineNumber>.+    +    > traceMessage:+    >   traceLinePattern:+    >   - tag: FullyQualifiedModule+    >   - contents: ':'+    >     tag: Delimiter+    >   - tag: FunctionName+    >   - contents: ' '+    >     tag: Delimiter+    >   - tag: LiteralMessage+    >   - tag: Variables+    +    In a small function, a trace expression, containing only a space+    separated list of variables, is still very informative, because the rest+    is done by the library based on the expression context and+    configuration. The function name gives literal part for tracing. The+    library understands Haskell syntax very well and variables can be+    copy\/pasted in bulk “AS-IS” with comments and even pattern matching.+    +    > module Module where+    > fun x (Just y) = $(tr "/x (Just y)") $ x + y+    +    The expression and config from above following trace message is+    produced:+    +    > Module:fun ; x: 123; y: 777+    +    The argument of @tr@ consists of literal message and list of variables+    for tracing. These parts are split by right slash.+    +    == Trace control+    #trace-control#+    +    Trace control has several dimensions.+    +    === Compile\/run time+    #compilerun-time#+    +    Tracing code generation can be disabled at compile time in the+    <#configuration-file config file> or later at launch runtime via an+    environment variable. The variable name depends on configuration and by+    default it is a cabal package name (in upper case) prefixed with+    @TRACE_EMBRACE_@.+    +    > mode:+    >   # expand all tracing macros to 'id' or 'pure ()' depending on the context+    >   tag: TraceDisabled+    +    ________________________________________________________________________+    +    > mode:+    >   # use Debug.Trace.trace group of functions+    >   tag: TraceStd+    > runtimeLevelsOverrideEnvVar:+    >   # disable runtime configuration+    >   tag: Ignored+    +    ________________________________________________________________________+    +    If the environment variable is not defined then tracing is enabled. If+    the variable expands to a dash (@-@) then tracing is disabled. Otherwise+    the variable should contain a path to a file with module prefixes+    specifing trace levels. Structure of runtime config file is equal to the+    structure of @levels@ section.+    +    > levels:+    > - '!Data.Map.Strict'     # exclamation mark is warning level+    > - '|Control.Concurrent'  # bar - bottom -> is error level+    > - 'Foo.Bar'              # default is info level+    > - '-'                    # dash is trace level+    > mode:+    >   tag: TraceStd+    > runtimeLevelsOverrideEnvVar:+    >   tag: CapsPackageName   # default+    +    ________________________________________________________________________+    +    === Tracing levels+    #tracing-levels#+    +    Both Haskell modules and tracing expressions have tracing levels. If+    expression tracing level is greater or equal to thershold tracing level+    of containing module then the message is emitted. Modules by default+    have threshold trace and unprefixed literal message has tracing level+    info.+    +    > module Module where+    > yes x = $(tr "!I am emitted/") x+    > yep x $(tr "|I am emitted/") x+    > no x = $(tr "I am not emitted/") x+    > nope x = $(tr "-I am not emitted/") x+    +    ________________________________________________________________________+    +    > levels:+    > - '!Foo'+    > - '-Fo'+    > - '#Foo.Bar'+    +    Runtime tracing level for a module cannot relax compile time tracing+    level.+    +    Every cabal package uses a dedicated envirnonment variable so no+    conflict between dependencies using trace-embarce library is likely+    possible.+    +    === Trace Sink+    #trace-sink#+    +    Besides+    <https://hackage.haskell.org/package/base/docs/Debug-Trace.html#v:trace Debug.Trace.trace>+    and @\/dev\/null@,+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:trIo trIo>,+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:tr tr>+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:tw tw>+    and+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:tw%27 tw\'>+    functions can forward tracing messages to+    <https://hackage.haskell.org/package/base/docs/System-IO.html#v:hPutStrLn hPutStrLn>+    or+    <https://hackage.haskell.org/package/base/docs/Debug-Trace.html#v:traceEvent Debug.Trace.traceEvent>.+    +    > mode:+    >   tag: TraceEvent+    +    ________________________________________________________________________+    +    > mode:+    >   sink:+    >     contents: /tmp/log.log+    >     tag: FileSink+    >   tag: TraceUnsafeIo+    +    ________________________________________________________________________+    +    > mode:+    >   sink:+    >     tag: StdErrSink+    >   tag: TraceUnsafeIo+    +    ==  Configuration file+    #configuration-file#+    +    The file is generanted on build if missing.+    +    === Default compile time config file (trace-embrace.yaml)+    #default-compile-time-config-file-trace-embrace.yaml#+    +    > levels:+    > - '-'+    > mode:+    >   tag: TraceStd+    > runtimeLevelsOverrideEnvVar:+    >   tag: CapsPackageName+    > traceMessage:+    >   entrySeparator: '; '+    >   keyValueSeparator: ': '+    >   retValPrefix: ' => '+    >   traceLinePattern:+    >   - tag: FullyQualifiedModule+    >   - contents: '::'+    >     tag: Delimiter+    >   - tag: FunctionName+    >   - contents: ': '+    >     tag: Delimiter+    >   - tag: LiteralMessage+    >   - tag: Variables+    > version: 1+    +    === Sample of runtime config file+    #sample-of-runtime-config-file#+    +    Runtime config file is also in YAML format, but its structure is way+    simpler.+    +    > - '-'         # empty prefix set default thershold equal to trace level+    > - '!Foo'+    > - 'Fo'+    > - '#Foo.Bar'  # threshold higher than error - disable tracing expression+    +    Passing runtime config to @foo-bar.cabal@:+    +    > TRACE_EMBRACE_FOO_BAR=- ./foo        # disable tracing+    > TRACE_EMBRACE_FOO_BAR=rtc.yaml ./foo # override threshold levels+    +    The variable name can be specified explicitly:+    +    > runtimeLevelsOverrideEnvVar:+    >   tag: EnvironmentVariable+    >   varName: "FOO_BAR"+    +    == Examples+    #examples#+    +    === TH version of traceWith+    #th-version-of-tracewith#+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module Module where+    >+    > import Debug.TraceEmbrace+    >+    > fun :: Int -> Int -> Int -> Int+    > fun x y z = $(tw "get/x y z") (x + y + z)+    +    A trace line for the snippet above would be:+    +    Module:fun: 7 get; x: 1; y: 2; z: 3 => 6+    +    === Trace lazy ByteString structure+    #trace-lazy-bytestring-structure#+    +    <https://hackage.haskell.org/package/bytestring/docs/Data-ByteString-Lazy.html#t:ByteString ByteString>+    @Show@ instance does not show chunks, but it can be important in parser+    debugging (attoparsec). Value of a type with not enough informative+    @Show@ instance could be wrapped into+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#t:ShowTrace ShowTrace>+    and more detailed @Show@ instance should be provided.+    +    > {-# LANGUAGE OverloadedStrings #-}+    > {-# LANGUAGE TemplateHaskell #-}+    > module Module where+    >+    > import Debug.TraceEmbrace+    > import Data.ByteString.Lazy+    >+    > -- instance Show (ShowTrace ByteString) where+    > --   show ...+    >+    > fun :: ByteString -> ByteString+    > fun bs = $(tr "get/bs;bs") bs+    +    A trace line for the snippet above would be:+    +    Module:fun: 11 get; bs: “abc”; bs: [“ab”, “c”]+    +    For tracing returning values wrapped into+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#t:ShowTrace ShowTrace>+    use+    <https://hackage.haskell.org/package/trace-embrace/docs/Debug-TraceEmbrace.html#v:tw%27 tw\'>.+    +    === Pattern matching syntax+    #pattern-matching-syntax#+    +    Template tracing functions support Haskell pattern syntax and comments,+    so function arguments can be quickly copy-pasted as-is:+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module Module where+    >+    > import Debug.TraceEmbrace+    >+    > fun :: Maybe ([Int], Int) -> Int+    > fun v@(Just ([x], {-ignore-} _)) = $(tr "get/v@(Just ([x], {-ignore-} _))") x+    > fun _ = 0+    +    A trace line for the snippet above would be:+    +    Module:fun: 7 get; v: Just 1; x: 1+    +    === Unlifted vars+    #unlifted-vars#+    +    > {-# LANGUAGE TemplateHaskell #-}+    > {-# LANGUAGE MagicHash #-}+    > module Module where+    >+    > import Debug.TraceEmbrace+    > import GHC.Exts+    >+    > fun :: Int -> Int+    > fun (I# x#) = (I# ($(tr "get/x#") x#))+    +    A trace line for the snippet above would be:+    +    Module:fun: 7 get; x#: 1#++tested-with:+  GHC == 9.10.1+extra-doc-files:+  changelog.md+library+  build-depends:+    aeson < 3.0,+    base < 5,+    bytestring > 0.11 && < 0.12.3,+    containers < 0.9,+    cpphs < 2.0,+    deepseq < 1.8,+    directory < 2.0,+    lens < 6.0,+    lrucache < 1.3,+    generic-lens < 3.0,+    ghc < 9.12,+    radix-tree < 2.0,+    refined < 1.0,+    tagged < 1.0,+    template-haskell < 2.24.0.0,+    text < 3.0,+    transformers < 1.0,+    yaml < 0.12,+  exposed-modules:+    Debug.TraceEmbrace+    Debug.TraceEmbrace.ByteString+    Debug.TraceEmbrace.Config+    Debug.TraceEmbrace.Config.Type+    Debug.TraceEmbrace.Config.Type.EnvVar+    Debug.TraceEmbrace.Config.Type.Level+    Debug.TraceEmbrace.Config.Type.Mode+    Debug.TraceEmbrace.Config.Type.TraceMessage+    Debug.TraceEmbrace.Config.Load+    Debug.TraceEmbrace.Config.Validation+    Debug.TraceEmbrace.FileIndex+    Debug.TraceEmbrace.Haddock+    Debug.TraceEmbrace.Internal.Rewrap+    Debug.TraceEmbrace.Internal.TH+    Debug.TraceEmbrace.Show+    Debug.TraceEmbrace.ShowTh+    Debug.TraceEmbrace.TH++  ghc-options: -Wall+  hs-source-dirs: src+  default-language: Haskell2010+  default-extensions:+    BangPatterns+    DataKinds+    DeriveGeneric+    DeriveLift+    DisambiguateRecordFields+    DuplicateRecordFields+    FlexibleContexts+    FlexibleInstances+    ImportQualifiedPost+    LambdaCase+    MultiParamTypeClasses+    OverloadedLabels+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TypeApplications+    TypeFamilies++test-suite test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+    Debug.TraceEmbrace.Test.TraceEmbrace.Config+    Debug.TraceEmbrace.Test.TraceEmbrace.DemoIndex+    Debug.TraceEmbrace.Test.TraceEmbrace.FileIndex+    Debug.TraceEmbrace.Test.TraceEmbrace.TH+    Debug.TraceEmbrace.Test.TraceEmbrace.TH.Event+    Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Lifted+    Debug.TraceEmbrace.Test.TraceEmbrace.TH.Format.Unboxed+    Debug.TraceEmbrace.Test.TraceEmbrace.TH.Line+    Debug.TraceEmbrace.Test.TraceEmbrace.TH.Threshold+    Debug.TraceEmbrace.Test.TraceEmbrace.Yaml+    Demo+    Discovery+    Paths_trace_embrace+  autogen-modules:+    Paths_trace_embrace+  hs-source-dirs:+    test+  default-extensions:+    BangPatterns+    DisambiguateRecordFields+    DuplicateRecordFields+    FlexibleContexts+    ImportQualifiedPost+    LambdaCase+    NamedFieldPuns+    OverloadedLabels+    RecordWildCards+    ScopedTypeVariables+    TemplateHaskell+  ghc-options: -Wall -rtsopts -threaded -main-is Driver+  build-depends:+      base+    , bytestring+    , containers+    , directory+    , filepath < 1.6+    , generic-lens+    , lens+    , lrucache < 1.3+    , refined+    , tasty+    , tasty-discover+    , tasty-hunit+    , tasty-quickcheck+    , template-haskell+    , temporary < 1.5+    , text+    , trace-embrace+    , yaml+  default-language: Haskell2010++source-repository head+  type:     git+  location: https://github.com/yaitskov/trace-embrace.git