{-|
Copyright        : (c) Galois, Inc 2015
Maintainer       : Simon Winwood <sjw@galois.com>

Provides utilities for logging debug messages to stderr.
-}
{-# LANGUAGE ImplicitParams #-}
module Data.Macaw.DebugLogging
       ( DebugClass(..)
       , setDebugKeys
       , getDebugKeys
       , allDebugKeys
       , debugKeyDescription
       , debugKeyName
       , parseDebugKey
       , unsetDebugKeys
       -- , debugKeys
       , debug
       , debug'
       , debugM
       , debugM'
       ) where

import Data.IORef
import Data.List (find, (\\))
import Debug.Trace
import GHC.Stack
import Prettyprinter
import Prettyprinter.Render.String
import System.IO.Unsafe -- For debugKeys

{-# NOINLINE debugKeys #-}
debugKeys :: IORef [DebugClass]
debugKeys :: IORef [DebugClass]
debugKeys = IO (IORef [DebugClass]) -> IORef [DebugClass]
forall a. IO a -> a
unsafePerformIO (IO (IORef [DebugClass]) -> IORef [DebugClass])
-> IO (IORef [DebugClass]) -> IORef [DebugClass]
forall a b. (a -> b) -> a -> b
$ [DebugClass] -> IO (IORef [DebugClass])
forall a. a -> IO (IORef a)
newIORef [DebugClass
DUrgent]

setDebugKeys :: [DebugClass] -> IO ()
setDebugKeys :: [DebugClass] -> IO ()
setDebugKeys [DebugClass]
keys = IORef [DebugClass] -> [DebugClass] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [DebugClass]
debugKeys [DebugClass]
keys

unsetDebugKeys :: [DebugClass] -> IO ()
unsetDebugKeys :: [DebugClass] -> IO ()
unsetDebugKeys [DebugClass]
keys = do
  IORef [DebugClass] -> ([DebugClass] -> [DebugClass]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [DebugClass]
debugKeys ([DebugClass] -> [DebugClass] -> [DebugClass]
forall a. Eq a => [a] -> [a] -> [a]
\\ [DebugClass]
keys)

getDebugKeys :: [DebugClass]
getDebugKeys :: [DebugClass]
getDebugKeys = IO [DebugClass] -> [DebugClass]
forall a. IO a -> a
unsafePerformIO (IO [DebugClass] -> [DebugClass])
-> IO [DebugClass] -> [DebugClass]
forall a b. (a -> b) -> a -> b
$ IORef [DebugClass] -> IO [DebugClass]
forall a. IORef a -> IO a
readIORef IORef [DebugClass]
debugKeys

allDebugKeys :: [DebugClass]
allDebugKeys :: [DebugClass]
allDebugKeys = [Int -> DebugClass
forall a. Enum a => Int -> a
toEnum Int
0 .. ]

-- Basically a tag we can use to turn on/off debug messages (only at
-- compile time though).
data DebugClass = DUrgent | DAbsInt | DCFG | DFunRecover | DFunctionArgs | DRegisterUse
                deriving (DebugClass -> DebugClass -> Bool
(DebugClass -> DebugClass -> Bool)
-> (DebugClass -> DebugClass -> Bool) -> Eq DebugClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugClass -> DebugClass -> Bool
== :: DebugClass -> DebugClass -> Bool
$c/= :: DebugClass -> DebugClass -> Bool
/= :: DebugClass -> DebugClass -> Bool
Eq, Eq DebugClass
Eq DebugClass =>
(DebugClass -> DebugClass -> Ordering)
-> (DebugClass -> DebugClass -> Bool)
-> (DebugClass -> DebugClass -> Bool)
-> (DebugClass -> DebugClass -> Bool)
-> (DebugClass -> DebugClass -> Bool)
-> (DebugClass -> DebugClass -> DebugClass)
-> (DebugClass -> DebugClass -> DebugClass)
-> Ord DebugClass
DebugClass -> DebugClass -> Bool
DebugClass -> DebugClass -> Ordering
DebugClass -> DebugClass -> DebugClass
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 :: DebugClass -> DebugClass -> Ordering
compare :: DebugClass -> DebugClass -> Ordering
$c< :: DebugClass -> DebugClass -> Bool
< :: DebugClass -> DebugClass -> Bool
$c<= :: DebugClass -> DebugClass -> Bool
<= :: DebugClass -> DebugClass -> Bool
$c> :: DebugClass -> DebugClass -> Bool
> :: DebugClass -> DebugClass -> Bool
$c>= :: DebugClass -> DebugClass -> Bool
>= :: DebugClass -> DebugClass -> Bool
$cmax :: DebugClass -> DebugClass -> DebugClass
max :: DebugClass -> DebugClass -> DebugClass
$cmin :: DebugClass -> DebugClass -> DebugClass
min :: DebugClass -> DebugClass -> DebugClass
Ord, Int -> DebugClass
DebugClass -> Int
DebugClass -> [DebugClass]
DebugClass -> DebugClass
DebugClass -> DebugClass -> [DebugClass]
DebugClass -> DebugClass -> DebugClass -> [DebugClass]
(DebugClass -> DebugClass)
-> (DebugClass -> DebugClass)
-> (Int -> DebugClass)
-> (DebugClass -> Int)
-> (DebugClass -> [DebugClass])
-> (DebugClass -> DebugClass -> [DebugClass])
-> (DebugClass -> DebugClass -> [DebugClass])
-> (DebugClass -> DebugClass -> DebugClass -> [DebugClass])
-> Enum DebugClass
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 :: DebugClass -> DebugClass
succ :: DebugClass -> DebugClass
$cpred :: DebugClass -> DebugClass
pred :: DebugClass -> DebugClass
$ctoEnum :: Int -> DebugClass
toEnum :: Int -> DebugClass
$cfromEnum :: DebugClass -> Int
fromEnum :: DebugClass -> Int
$cenumFrom :: DebugClass -> [DebugClass]
enumFrom :: DebugClass -> [DebugClass]
$cenumFromThen :: DebugClass -> DebugClass -> [DebugClass]
enumFromThen :: DebugClass -> DebugClass -> [DebugClass]
$cenumFromTo :: DebugClass -> DebugClass -> [DebugClass]
enumFromTo :: DebugClass -> DebugClass -> [DebugClass]
$cenumFromThenTo :: DebugClass -> DebugClass -> DebugClass -> [DebugClass]
enumFromThenTo :: DebugClass -> DebugClass -> DebugClass -> [DebugClass]
Enum, Int -> DebugClass -> ShowS
[DebugClass] -> ShowS
DebugClass -> String
(Int -> DebugClass -> ShowS)
-> (DebugClass -> String)
-> ([DebugClass] -> ShowS)
-> Show DebugClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugClass -> ShowS
showsPrec :: Int -> DebugClass -> ShowS
$cshow :: DebugClass -> String
show :: DebugClass -> String
$cshowList :: [DebugClass] -> ShowS
showList :: [DebugClass] -> ShowS
Show)

supportedKeys :: [(String, DebugClass, String)]
supportedKeys :: [(String, DebugClass, String)]
supportedKeys = [ (String
"urgent", DebugClass
DUrgent, String
"High priority warnings")
                , (String
"absint", DebugClass
DAbsInt, String
"Abstract interpretation phase")
                , (String
"cfg", DebugClass
DCFG, String
"CFG discovery phase")
                , (String
"recover", DebugClass
DFunRecover, String
"Function recovery phase")
                , (String
"reguse", DebugClass
DRegisterUse, String
"Register use")
                , (String
"funargs", DebugClass
DFunctionArgs, String
"Function argument discovery phase") ]

debugKeyDescription :: DebugClass -> String
debugKeyDescription :: DebugClass -> String
debugKeyDescription DebugClass
k =
  case ((String, DebugClass, String) -> Bool)
-> [(String, DebugClass, String)]
-> Maybe (String, DebugClass, String)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (\(String
_, DebugClass
k', String
_) -> DebugClass
k DebugClass -> DebugClass -> Bool
forall a. Eq a => a -> a -> Bool
== DebugClass
k') [(String, DebugClass, String)]
supportedKeys of
    Maybe (String, DebugClass, String)
Nothing -> ShowS
forall a. HasCallStack => String -> a
error String
"Missing debug key"
    Just (String
_, DebugClass
_, String
descr) -> String
descr

debugKeyName :: DebugClass -> String
debugKeyName :: DebugClass -> String
debugKeyName DebugClass
k =
  case ((String, DebugClass, String) -> Bool)
-> [(String, DebugClass, String)]
-> Maybe (String, DebugClass, String)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (\(String
_, DebugClass
k', String
_) -> DebugClass
k DebugClass -> DebugClass -> Bool
forall a. Eq a => a -> a -> Bool
== DebugClass
k') [(String, DebugClass, String)]
supportedKeys of
    Maybe (String, DebugClass, String)
Nothing -> ShowS
forall a. HasCallStack => String -> a
error String
"Missing debug key"
    Just (String
n, DebugClass
_, String
_) -> String
n

parseDebugKey :: String -> Maybe DebugClass
parseDebugKey :: String -> Maybe DebugClass
parseDebugKey String
n =
  (\(String
_, DebugClass
k, String
_) -> DebugClass
k) ((String, DebugClass, String) -> DebugClass)
-> Maybe (String, DebugClass, String) -> Maybe DebugClass
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, DebugClass, String) -> Bool)
-> [(String, DebugClass, String)]
-> Maybe (String, DebugClass, String)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find (\(String
n', DebugClass
_, String
_) -> String
n' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n) [(String, DebugClass, String)]
supportedKeys

{-# INLINE debug #-}
debug :: (?loc :: CallStack) => DebugClass -> String -> a -> a
debug :: forall a. (?loc::CallStack) => DebugClass -> String -> a -> a
debug DebugClass
cl String
msg a
x
  | DebugClass
cl DebugClass -> [DebugClass] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [DebugClass]
getDebugKeys =
      -- let doesn't work here, it seems to break the magic that is ?loc
      String -> a -> a
forall a. String -> a -> a
trace (SrcLoc -> String
srcLocFile ((String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ([(String, SrcLoc)] -> (String, SrcLoc)
forall a. HasCallStack => [a] -> a
last (CallStack -> [(String, SrcLoc)]
getCallStack ?loc::CallStack
CallStack
?loc))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine ((String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ([(String, SrcLoc)] -> (String, SrcLoc)
forall a. HasCallStack => [a] -> a
last (CallStack -> [(String, SrcLoc)]
getCallStack ?loc::CallStack
CallStack
?loc)))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ["
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DebugClass -> String
debugKeyName DebugClass
cl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg) a
x
  | Bool
otherwise = a
x
  where
    -- fn = show (getCallStack ?loc)

debug' :: DebugClass -> Doc ann -> a -> a
debug' :: forall ann a. DebugClass -> Doc ann -> a -> a
debug' DebugClass
cl Doc ann
msg a
x = DebugClass -> String -> a -> a
forall a. (?loc::CallStack) => DebugClass -> String -> a -> a
debug DebugClass
cl (SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
renderString (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
opts Doc ann
msg)) a
x
  where opts :: LayoutOptions
opts = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
100 Double
0.8)

{-# INLINE debugM #-}
debugM :: (?loc :: CallStack, Monad m) => DebugClass -> String -> m ()
debugM :: forall (m :: Type -> Type).
(?loc::CallStack, Monad m) =>
DebugClass -> String -> m ()
debugM DebugClass
cl String
msg
  | DebugClass
cl DebugClass -> [DebugClass] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [DebugClass]
getDebugKeys =
      -- let doesn't work here, it seems to break the magic that is ?loc
      String -> m ()
forall (f :: Type -> Type). Applicative f => String -> f ()
traceM (SrcLoc -> String
srcLocFile ((String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ([(String, SrcLoc)] -> (String, SrcLoc)
forall a. HasCallStack => [a] -> a
last (CallStack -> [(String, SrcLoc)]
getCallStack ?loc::CallStack
CallStack
?loc))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine ((String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ([(String, SrcLoc)] -> (String, SrcLoc)
forall a. HasCallStack => [a] -> a
last (CallStack -> [(String, SrcLoc)]
getCallStack ?loc::CallStack
CallStack
?loc)))) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ["
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ DebugClass -> String
debugKeyName DebugClass
cl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)
  | Bool
otherwise = () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

debugM' :: Monad m => DebugClass -> Doc ann -> m ()
debugM' :: forall (m :: Type -> Type) ann.
Monad m =>
DebugClass -> Doc ann -> m ()
debugM' DebugClass
cl Doc ann
msg = DebugClass -> String -> m ()
forall (m :: Type -> Type).
(?loc::CallStack, Monad m) =>
DebugClass -> String -> m ()
debugM DebugClass
cl (SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
renderString (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
opts Doc ann
msg))
  where opts :: LayoutOptions
opts = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine Int
100 Double
0.8)