{-# LANGUAGE OverloadedStrings #-}
-- pTrace
{-# OPTIONS_GHC -Wno-deprecations #-}

module Unison.Debug
  ( debug,
    debugM,
    whenDebug,
    debugLog,
    debugLogM,
    shouldDebug,
    DebugFlag (..),
  )
where

import Data.Set qualified as Set
import Data.Text qualified as Text
import Debug.Pretty.Simple (pTrace, pTraceM)
import System.IO.Unsafe (unsafePerformIO)
import Text.Pretty.Simple (pShow)
import Unison.Prelude
import UnliftIO.Environment (lookupEnv)

data DebugFlag
  = Auth
  | Codebase
  | Integrity
  | Merge
  | Migration
  | Sqlite
  | Sync
  | -- Language server
    LSP
  | -- | Timing how long things take
    Timing
  | -- | Useful for adding temporary debugging statements during development.
    -- Remove uses of Debug.Temp before merging to keep things clean for the next person :)
    Temp
  | -- | Shows Annotations when printing terms
    Annotations
  | -- | Debug endpoints of the local UI (or Share) server
    Server
  | PatternCoverage
  | PatternCoverageConstraintSolver
  | KindInference
  | Update
  deriving (DebugFlag -> DebugFlag -> Bool
(DebugFlag -> DebugFlag -> Bool)
-> (DebugFlag -> DebugFlag -> Bool) -> Eq DebugFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugFlag -> DebugFlag -> Bool
== :: DebugFlag -> DebugFlag -> Bool
$c/= :: DebugFlag -> DebugFlag -> Bool
/= :: DebugFlag -> DebugFlag -> Bool
Eq, Eq DebugFlag
Eq DebugFlag =>
(DebugFlag -> DebugFlag -> Ordering)
-> (DebugFlag -> DebugFlag -> Bool)
-> (DebugFlag -> DebugFlag -> Bool)
-> (DebugFlag -> DebugFlag -> Bool)
-> (DebugFlag -> DebugFlag -> Bool)
-> (DebugFlag -> DebugFlag -> DebugFlag)
-> (DebugFlag -> DebugFlag -> DebugFlag)
-> Ord DebugFlag
DebugFlag -> DebugFlag -> Bool
DebugFlag -> DebugFlag -> Ordering
DebugFlag -> DebugFlag -> DebugFlag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DebugFlag -> DebugFlag -> Ordering
compare :: DebugFlag -> DebugFlag -> Ordering
$c< :: DebugFlag -> DebugFlag -> Bool
< :: DebugFlag -> DebugFlag -> Bool
$c<= :: DebugFlag -> DebugFlag -> Bool
<= :: DebugFlag -> DebugFlag -> Bool
$c> :: DebugFlag -> DebugFlag -> Bool
> :: DebugFlag -> DebugFlag -> Bool
$c>= :: DebugFlag -> DebugFlag -> Bool
>= :: DebugFlag -> DebugFlag -> Bool
$cmax :: DebugFlag -> DebugFlag -> DebugFlag
max :: DebugFlag -> DebugFlag -> DebugFlag
$cmin :: DebugFlag -> DebugFlag -> DebugFlag
min :: DebugFlag -> DebugFlag -> DebugFlag
Ord, Int -> DebugFlag -> ShowS
[DebugFlag] -> ShowS
DebugFlag -> String
(Int -> DebugFlag -> ShowS)
-> (DebugFlag -> String)
-> ([DebugFlag] -> ShowS)
-> Show DebugFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugFlag -> ShowS
showsPrec :: Int -> DebugFlag -> ShowS
$cshow :: DebugFlag -> String
show :: DebugFlag -> String
$cshowList :: [DebugFlag] -> ShowS
showList :: [DebugFlag] -> ShowS
Show, DebugFlag
DebugFlag -> DebugFlag -> Bounded DebugFlag
forall a. a -> a -> Bounded a
$cminBound :: DebugFlag
minBound :: DebugFlag
$cmaxBound :: DebugFlag
maxBound :: DebugFlag
Bounded, Int -> DebugFlag
DebugFlag -> Int
DebugFlag -> [DebugFlag]
DebugFlag -> DebugFlag
DebugFlag -> DebugFlag -> [DebugFlag]
DebugFlag -> DebugFlag -> DebugFlag -> [DebugFlag]
(DebugFlag -> DebugFlag)
-> (DebugFlag -> DebugFlag)
-> (Int -> DebugFlag)
-> (DebugFlag -> Int)
-> (DebugFlag -> [DebugFlag])
-> (DebugFlag -> DebugFlag -> [DebugFlag])
-> (DebugFlag -> DebugFlag -> [DebugFlag])
-> (DebugFlag -> DebugFlag -> DebugFlag -> [DebugFlag])
-> Enum DebugFlag
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: DebugFlag -> DebugFlag
succ :: DebugFlag -> DebugFlag
$cpred :: DebugFlag -> DebugFlag
pred :: DebugFlag -> DebugFlag
$ctoEnum :: Int -> DebugFlag
toEnum :: Int -> DebugFlag
$cfromEnum :: DebugFlag -> Int
fromEnum :: DebugFlag -> Int
$cenumFrom :: DebugFlag -> [DebugFlag]
enumFrom :: DebugFlag -> [DebugFlag]
$cenumFromThen :: DebugFlag -> DebugFlag -> [DebugFlag]
enumFromThen :: DebugFlag -> DebugFlag -> [DebugFlag]
$cenumFromTo :: DebugFlag -> DebugFlag -> [DebugFlag]
enumFromTo :: DebugFlag -> DebugFlag -> [DebugFlag]
$cenumFromThenTo :: DebugFlag -> DebugFlag -> DebugFlag -> [DebugFlag]
enumFromThenTo :: DebugFlag -> DebugFlag -> DebugFlag -> [DebugFlag]
Enum)

debugFlags :: Set DebugFlag
debugFlags :: Set DebugFlag
debugFlags = case (IO (Maybe String) -> Maybe String
forall a. IO a -> a
unsafePerformIO (String -> IO (Maybe String)
forall (m :: * -> *). MonadIO m => String -> m (Maybe String)
lookupEnv String
"UNISON_DEBUG")) of
  Maybe String
Nothing -> Set DebugFlag
forall a. Set a
Set.empty
  -- Enable all debugging flags for bare UNISON_DEBUG declarations like:
  -- UNISON_DEBUG= ucm
  Just String
"" -> [DebugFlag] -> Set DebugFlag
forall a. Ord a => [a] -> Set a
Set.fromList [DebugFlag
forall a. Bounded a => a
minBound .. DebugFlag
forall a. Bounded a => a
maxBound]
  Just String
s -> [DebugFlag] -> Set DebugFlag
forall a. Ord a => [a] -> Set a
Set.fromList ([DebugFlag] -> Set DebugFlag) -> [DebugFlag] -> Set DebugFlag
forall a b. (a -> b) -> a -> b
$ do
    Text
w <- (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"," (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ String
s)
    case Text -> Text
Text.toUpper (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
w of
      Text
"AUTH" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Auth
      Text
"CODEBASE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Codebase
      Text
"INTEGRITY" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Integrity
      Text
"MERGE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Merge
      Text
"MIGRATION" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Migration
      Text
"SQLITE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Sqlite
      Text
"SYNC" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Sync
      Text
"LSP" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
LSP
      Text
"TIMING" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Timing
      Text
"TEMP" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Temp
      Text
"ANNOTATIONS" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Annotations
      Text
"SERVER" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Server
      Text
"PATTERN_COVERAGE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
PatternCoverage
      Text
"PATTERN_COVERAGE_CONSTRAINT_SOLVER" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
PatternCoverageConstraintSolver
      Text
"KIND_INFERENCE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
KindInference
      Text
"UPDATE" -> DebugFlag -> [DebugFlag]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure DebugFlag
Update
      Text
_ -> [DebugFlag]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
{-# NOINLINE debugFlags #-}

debugSqlite :: Bool
debugSqlite :: Bool
debugSqlite = DebugFlag
Sqlite DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugSqlite #-}

debugCodebase :: Bool
debugCodebase :: Bool
debugCodebase = DebugFlag
Codebase DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugCodebase #-}

debugAuth :: Bool
debugAuth :: Bool
debugAuth = DebugFlag
Auth DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugAuth #-}

debugMerge :: Bool
debugMerge :: Bool
debugMerge = DebugFlag
Merge DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugMerge #-}

debugMigration :: Bool
debugMigration :: Bool
debugMigration = DebugFlag
Migration DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugMigration #-}

debugIntegrity :: Bool
debugIntegrity :: Bool
debugIntegrity = DebugFlag
Integrity DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugIntegrity #-}

debugSync :: Bool
debugSync :: Bool
debugSync = DebugFlag
Sync DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugSync #-}

debugLSP :: Bool
debugLSP :: Bool
debugLSP = DebugFlag
LSP DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugLSP #-}

debugTiming :: Bool
debugTiming :: Bool
debugTiming = DebugFlag
Timing DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugTiming #-}

debugTemp :: Bool
debugTemp :: Bool
debugTemp = DebugFlag
Temp DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugTemp #-}

debugAnnotations :: Bool
debugAnnotations :: Bool
debugAnnotations = DebugFlag
Annotations DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugAnnotations #-}

debugServer :: Bool
debugServer :: Bool
debugServer = DebugFlag
Server DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugServer #-}

debugKindInference :: Bool
debugKindInference :: Bool
debugKindInference = DebugFlag
KindInference DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugKindInference #-}

debugUpdate :: Bool
debugUpdate :: Bool
debugUpdate = DebugFlag
Update DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugUpdate #-}

debugPatternCoverage :: Bool
debugPatternCoverage :: Bool
debugPatternCoverage = DebugFlag
PatternCoverage DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugPatternCoverage #-}

debugPatternCoverageConstraintSolver :: Bool
debugPatternCoverageConstraintSolver :: Bool
debugPatternCoverageConstraintSolver = DebugFlag
PatternCoverageConstraintSolver DebugFlag -> Set DebugFlag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set DebugFlag
debugFlags
{-# NOINLINE debugPatternCoverageConstraintSolver #-}

-- | Use for trace-style selective debugging.
-- E.g. 1 + (debug Sync "The second number" 2)
--
-- Or, use in pattern matching to view arguments.
-- E.g.
-- myFunc (debug Sync "argA" -> argA) = ...
debug :: (Show a) => DebugFlag -> String -> a -> a
debug :: forall a. Show a => DebugFlag -> String -> a -> a
debug DebugFlag
flag String
msg a
a =
  if DebugFlag -> Bool
shouldDebug DebugFlag
flag
    then (String -> a -> a
forall a. String -> a -> a
trace (String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @String (a -> Text
forall a. Show a => a -> Text
pShow a
a)) a
a)
    else a
a

-- | Use for selective debug logging in monadic contexts.
-- E.g.
-- do
--   debugM Sync "source repo" srcRepo
--   ...
debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m ()
debugM :: forall a (m :: * -> *).
(Show a, Monad m) =>
DebugFlag -> String -> a -> m ()
debugM DebugFlag
flag String
msg a
a =
  DebugFlag -> m () -> m ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
whenDebug DebugFlag
flag do
    String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM (String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> forall target source. From source target => source -> target
into @String (a -> Text
forall a. Show a => a -> Text
pShow a
a))

debugLog :: DebugFlag -> String -> a -> a
debugLog :: forall a. DebugFlag -> String -> a -> a
debugLog DebugFlag
flag String
msg =
  if DebugFlag -> Bool
shouldDebug DebugFlag
flag
    then String -> a -> a
forall a. String -> a -> a
pTrace String
msg
    else a -> a
forall a. a -> a
id

debugLogM :: (Monad m) => DebugFlag -> String -> m ()
debugLogM :: forall (m :: * -> *). Monad m => DebugFlag -> String -> m ()
debugLogM DebugFlag
flag String
msg =
  DebugFlag -> m () -> m ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
whenDebug DebugFlag
flag (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
pTraceM String
msg

-- | A 'when' block which is triggered if the given flag is being debugged.
whenDebug :: (Monad m) => DebugFlag -> m () -> m ()
whenDebug :: forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
whenDebug DebugFlag
flag m ()
action = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DebugFlag -> Bool
shouldDebug DebugFlag
flag) m ()
action

shouldDebug :: DebugFlag -> Bool
shouldDebug :: DebugFlag -> Bool
shouldDebug = \case
  DebugFlag
Auth -> Bool
debugAuth
  DebugFlag
Codebase -> Bool
debugCodebase
  DebugFlag
Integrity -> Bool
debugIntegrity
  DebugFlag
Merge -> Bool
debugMerge
  DebugFlag
Migration -> Bool
debugMigration
  DebugFlag
Sqlite -> Bool
debugSqlite
  DebugFlag
Sync -> Bool
debugSync
  DebugFlag
LSP -> Bool
debugLSP
  DebugFlag
Timing -> Bool
debugTiming
  DebugFlag
Temp -> Bool
debugTemp
  DebugFlag
Annotations -> Bool
debugAnnotations
  DebugFlag
Server -> Bool
debugServer
  DebugFlag
PatternCoverage -> Bool
debugPatternCoverage
  DebugFlag
PatternCoverageConstraintSolver -> Bool
debugPatternCoverageConstraintSolver
  DebugFlag
KindInference -> Bool
debugKindInference
  DebugFlag
Update -> Bool
debugUpdate