{-# LANGUAGE DerivingVia, StandaloneDeriving, ViewPatterns, ImpredicativeTypes #-}
-- | The home of customizability for visualizing variables and values with @haskell-debugger@
module GHC.Debugger.View.Class
  (
    -- * Writing custom debug visualizations
    --
    -- | The entry point for custom visualizations is 'DebugView'.
    -- There are two axis of configuration:
    --
    -- 1. What to display inline in front of the variable name and whether it
    -- is expandable
    --
    -- 2. What fields are displayed when the value is expanded and what are
    -- their corresponding values
    --
    -- The former is answered by 'debugValue' / 'VarValue' and the latter by
    -- 'debugFields' / 'VarFields'.
    DebugView(..)

  , VarValue(..)
  , VarFields(..)
  , VarFieldValue(..)
  , simpleValue


    -- * A 'Program' can describe a more complicated visualisation method which
    -- can query some information from the debugger.
  , Program(..)
  , isThunk
  , ifP


  -- * Utilities
  --
  -- | These can make it easier to write your own custom instances.
  -- We also use them for the built-in custom instances.
  , BoringTy(..)

  -- * The internals
  --
  -- | These are used by @haskell-debugger@ when invoking these instances at
  -- runtime and reconstructing the result from the heap.
  --
  -- They should never be used by a user looking to write custom visualizations.
  , VarValueIO(..)
  , debugValueIOWrapper
  , VarFieldsIO(..)
  , debugFieldsIOWrapper
  )
  where

import Data.Int
import Data.Word

-- | Custom handling of debug terms (e.g. in the variables pane, or when
-- inspecting a lazy variable)
class DebugView a where

  -- | Compute the representation of a variable with the given value.
  --
  -- INVARIANT: this method should only called on values which are already in
  -- WHNF, never thunks.
  --
  -- That said, this method is responsible for determining how much it is
  -- forced when displaying it inline as a variable.
  --
  -- For instance, for @String@, @a@ will be fully forced to display the entire
  -- string in one go rather than as a linked list of @'Char'@.
  debugValue :: a -> VarValue

  -- | Compute the fields to display when expanding a value of type @a@.
  --
  -- This method should only be called to get the fields if the corresponding
  -- @'VarValue'@ has @'varExpandable' = True@.
  debugFields :: a -> Program VarFields

-- | The 'Program' abstraction allows more complicated 'DebugView' instances
-- to be constructed. The debugger will interpreter a 'Program' lazily when
-- determining how to display a variable.
--
-- At the moment the only interesting query when constructing a program is determining
-- if a value is already evaluated or not. This can be used to only display the evaluated
-- prefix of a list for example.
data Program a where
    -- | Lift a value to a program
    PureProgram :: a -> Program a
    -- | Program application
    ProgramAp :: Program (a -> b) -> Program a -> Program b
    -- | Evaluate the conditional, and branch on the result
    ProgramBranch :: Program Bool -> Program a -> Program a -> Program a
    -- | Is the value a thunk or evaluated?
    ProgramAskThunk :: a -> Program Bool

instance Functor Program where
   fmap :: forall a b. (a -> b) -> Program a -> Program b
fmap a -> b
f Program a
x = Program (a -> b) -> Program a -> Program b
forall a b. Program (a -> b) -> Program a -> Program b
ProgramAp ((a -> b) -> Program (a -> b)
forall a. a -> Program a
PureProgram a -> b
f) Program a
x

instance Applicative Program where
   pure :: forall a. a -> Program a
pure = a -> Program a
forall a. a -> Program a
PureProgram
   Program (a -> b)
fx <*> :: forall a b. Program (a -> b) -> Program a -> Program b
<*> Program a
fy = Program (a -> b) -> Program a -> Program b
forall a b. Program (a -> b) -> Program a -> Program b
ProgramAp Program (a -> b)
fx Program a
fy

-- | Construct a 'VarValue' which doesn't require a 'Program'.
simpleValue :: String -> Bool -> VarValue
simpleValue :: String -> Bool -> VarValue
simpleValue String
s Bool
b = Program String -> Bool -> VarValue
VarValue (String -> Program String
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s) Bool
b

-- | Construct a 'Program' which determines if 'a' is a thunk or not.
isThunk :: a -> Program Bool
isThunk :: forall a. a -> Program Bool
isThunk = a -> Program Bool
forall a. a -> Program Bool
ProgramAskThunk

-- | Construct a program which branches
ifP :: Program Bool -> Program a -> Program a -> Program a
ifP :: forall a. Program Bool -> Program a -> Program a -> Program a
ifP = Program Bool -> Program a -> Program a -> Program a
forall a. Program Bool -> Program a -> Program a -> Program a
ProgramBranch

-- | The representation of the value for some variable on the debugger
data VarValue = VarValue
  { -- | The value to display inline for this variable
    VarValue -> Program String
varValue      :: Program String

    -- | Can this variable further be expanded (s.t. @'debugFields'@ is not null?)
  , VarValue -> Bool
varExpandable :: Bool
  }

-- | The representation for fields of a value which is expandable in the debugger
newtype VarFields = VarFields
  { VarFields -> [(String, VarFieldValue)]
varFields :: [(String, VarFieldValue)]
  }

-- | A box for subfields of a value.
--
-- Used to construct the debug-view list of fields one gets from expanding a datatype.
-- See, for instance, the @DebugView (a, b)@ instance for an example of how it is used.
--
-- The boxed value is returned as is and can be further forced or expanded by
-- the debugger, using either the existing @'DebugView'@ instance for the
-- existential @a@ (the instance is found at runtime), or the generic runtime
-- term inspection mechanisms otherwise.
data VarFieldValue = forall a. VarFieldValue a

--------------------------------------------------------------------------------

-- | Boring types scaffolding.
--
-- Meant to be used like:
--
-- @
-- deriving via (BoringTy Int) instance (DebugView Int)
-- @
--
-- to derive a 'DebugView' for a type whose terms should always be fully forced
-- and displayed whole rather than as parts.
--
-- A boring type is one for which we don't care about the structure and would
-- rather see "whole" when being inspected. Strings and literals are a good
-- example, because it's more useful to see the string value than it is to see
-- a linked list of characters where each has to be forced individually.
newtype BoringTy a = BoringTy a

instance Show a => DebugView (BoringTy a) where
  debugValue :: BoringTy a -> VarValue
debugValue (BoringTy a
x) = String -> Bool -> VarValue
simpleValue (a -> String
forall a. Show a => a -> String
show a
x) Bool
False
  debugFields :: BoringTy a -> Program VarFields
debugFields BoringTy a
_           = VarFields -> Program VarFields
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarFields -> Program VarFields) -> VarFields -> Program VarFields
forall a b. (a -> b) -> a -> b
$ [(String, VarFieldValue)] -> VarFields
VarFields []

deriving via BoringTy Int     instance DebugView Int
deriving via BoringTy Int8    instance DebugView Int8
deriving via BoringTy Int16   instance DebugView Int16
deriving via BoringTy Int32   instance DebugView Int32
deriving via BoringTy Int64   instance DebugView Int64
deriving via BoringTy Word    instance DebugView Word
deriving via BoringTy Word8   instance DebugView Word8
deriving via BoringTy Word16  instance DebugView Word16
deriving via BoringTy Word32  instance DebugView Word32
deriving via BoringTy Word64  instance DebugView Word64
deriving via BoringTy Double  instance DebugView Double
deriving via BoringTy Float   instance DebugView Float
deriving via BoringTy Integer instance DebugView Integer
deriving via BoringTy Char    instance DebugView Char
deriving via BoringTy String  instance DebugView String

instance DebugView (a, b) where
  debugValue :: (a, b) -> VarValue
debugValue (a, b)
_ = String -> Bool -> VarValue
simpleValue String
"( , )" Bool
True
  debugFields :: (a, b) -> Program VarFields
debugFields (a
x, b
y) = VarFields -> Program VarFields
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarFields -> Program VarFields) -> VarFields -> Program VarFields
forall a b. (a -> b) -> a -> b
$ [(String, VarFieldValue)] -> VarFields
VarFields
    [ (String
"fst", a -> VarFieldValue
forall a. a -> VarFieldValue
VarFieldValue a
x)
    , (String
"snd", b -> VarFieldValue
forall a. a -> VarFieldValue
VarFieldValue b
y) ]

-- | This instance will display up to the first 50 forced elements of a list.
instance {-# OVERLAPPABLE #-} DebugView [a] where
  debugValue :: [a] -> VarValue
debugValue [] = String -> Bool -> VarValue
simpleValue String
"[]" Bool
False
  debugValue (a
_:[a]
_) = String -> Bool -> VarValue
simpleValue String
"[...]" Bool
True
  debugFields :: [a] -> Program VarFields
debugFields [a]
v = [(String, VarFieldValue)] -> VarFields
VarFields ([(String, VarFieldValue)] -> VarFields)
-> Program [(String, VarFieldValue)] -> Program VarFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [a] -> Program [(String, VarFieldValue)]
go Int
0 [a]
v
    where
      go :: Int -> [a] -> Program [(String, VarFieldValue)]
      go :: Int -> [a] -> Program [(String, VarFieldValue)]
go Int
50 [a]
xs = [(String, VarFieldValue)] -> Program [(String, VarFieldValue)]
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(String
"tail", [a] -> VarFieldValue
forall a. a -> VarFieldValue
VarFieldValue [a]
xs)]
      go Int
_ [] = [(String, VarFieldValue)] -> Program [(String, VarFieldValue)]
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      go Int
n (a
x:[a]
xs) = ((Int -> String
forall a. Show a => a -> String
show Int
n, a -> VarFieldValue
forall a. a -> VarFieldValue
VarFieldValue a
x) (String, VarFieldValue)
-> [(String, VarFieldValue)] -> [(String, VarFieldValue)]
forall a. a -> [a] -> [a]
:) ([(String, VarFieldValue)] -> [(String, VarFieldValue)])
-> Program [(String, VarFieldValue)]
-> Program [(String, VarFieldValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                      (Program Bool
-> Program [(String, VarFieldValue)]
-> Program [(String, VarFieldValue)]
-> Program [(String, VarFieldValue)]
forall a. Program Bool -> Program a -> Program a -> Program a
ifP ([a] -> Program Bool
forall a. a -> Program Bool
isThunk [a]
xs) ([(String, VarFieldValue)] -> Program [(String, VarFieldValue)]
forall a. a -> Program a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, VarFieldValue)] -> Program [(String, VarFieldValue)])
-> [(String, VarFieldValue)] -> Program [(String, VarFieldValue)]
forall a b. (a -> b) -> a -> b
$ [(String
"tail", [a] -> VarFieldValue
forall a. a -> VarFieldValue
VarFieldValue [a]
xs)])
                                        (Int -> [a] -> Program [(String, VarFieldValue)]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
xs))

--------------------------------------------------------------------------------
-- * (Internal) Wrappers required to call `evalStmt` on methods more easily
--------------------------------------------------------------------------------

-- | Wrapper to make evaluating from debugger easier
data VarValueIO = VarValueIO
  { VarValueIO -> Program (IO String)
varValueIO :: Program (IO String)
  , VarValueIO -> Bool
varExpandableIO :: Bool
  }

debugValueIOWrapper :: DebugView a => a -> IO [VarValueIO]
debugValueIOWrapper :: forall a. DebugView a => a -> IO [VarValueIO]
debugValueIOWrapper a
x = case a -> VarValue
forall a. DebugView a => a -> VarValue
debugValue a
x of
  VarValue Program String
str Bool
b ->
    [VarValueIO] -> IO [VarValueIO]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Program (IO String) -> Bool -> VarValueIO
VarValueIO (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> Program String -> Program (IO String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program String
str) Bool
b]

newtype VarFieldsIO = VarFieldsIO
  { VarFieldsIO -> Program [(IO String, VarFieldValue)]
varFieldsIO :: Program [(IO String, VarFieldValue)]
  }

debugFieldsIOWrapper :: DebugView a => a -> IO [VarFieldsIO]
debugFieldsIOWrapper :: forall a. DebugView a => a -> IO [VarFieldsIO]
debugFieldsIOWrapper a
x = [VarFieldsIO] -> IO [VarFieldsIO]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Program [(IO String, VarFieldValue)] -> VarFieldsIO
VarFieldsIO (VarFields -> [(IO String, VarFieldValue)]
toVarFieldsIO (VarFields -> [(IO String, VarFieldValue)])
-> Program VarFields -> Program [(IO String, VarFieldValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Program VarFields
forall a. DebugView a => a -> Program VarFields
debugFields a
x))]

toVarFieldsIO :: VarFields -> [(IO String, VarFieldValue)]
toVarFieldsIO :: VarFields -> [(IO String, VarFieldValue)]
toVarFieldsIO VarFields
x =
  case VarFields
x of
    VarFields [(String, VarFieldValue)]
fls -> [ (String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
fl_s, VarFieldValue
b) | (String
fl_s, VarFieldValue
b) <- [(String, VarFieldValue)]
fls]