heap-console-0.1.0.1: src/Heap/Console/Value.hs
{-# language AllowAmbiguousTypes, MagicHash #-}
-- | Utilities for inspection of Haskell values.
module Heap.Console.Value
( FromValue (..)
, Name (..)
, conName
, PrettyType
, prettyType
, RepM
, RepOptions (..)
, runRepM
, Value (..)
, valueFromData
, Box (..)
, asBox
, boxFromAny
, index
, prettyRep
) where
import Control.Applicative
import Control.Arrow hiding (first, second)
import Control.Exception
import Control.Monad.Except
import Control.Monad.Reader
import Data.Bifunctor
import Data.Bitraversable
import Data.Bool
import Data.Data
( constrFields, constrFixity, constrRep, ConstrRep (..), Data (..)
, Fixity (..), showConstr
)
import Data.Traversable
import Data.Function
import Data.Functor
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import GHC.Exts
import GHC.Exts.Heap
import GHC.Float
import GHC.Pack
import GHC.Stack
import Numeric.Natural
import System.IO.Unsafe
import System.Mem
import Text.Read (readMaybe)
import Text.Show.Combinators
import Type.Reflection
-------------------------------------------------------------------------------
-- | Interpretation of Haskell value into representation @r@. Allows user to
-- interpret inspection done by 'valueFromData' or 'boxFromAny' as needed.
data FromValue box rep = forall info. FromValue{
-- | Embeds information created about value together with it's @box@
-- (wrapped original value itself) into final representation. It allows one
-- to e.g. discard @box@ if not used.
box :: box -> info -> rep
, list :: [rep] -> Maybe box -> info
, string :: [Either box Char] -> Maybe box -> info
, char :: Char -> info
, tuple :: [rep] -> info
, con :: Name -> [Word] -> [rep] -> info
, rec :: Name -> [(String, rep)] -> info
, fun :: info
, thunk :: info
, bytecode :: info
, byteArray :: Word -> [Word] -> info
, mutByteArray :: info -- TODO: more precise
, mVar :: info -- TODO: more precise?
, mutVar :: rep -> info
, stmQueue :: info -- TODO: more precise?
, integral :: Integer -> PrettyType -> info
, floating :: Double -> PrettyType -> info
, int# :: Int -> info
, word# :: Word -> info
, int64# :: Int64 -> info
, word64# :: Word64 -> info
, addr# :: Int -> info
, float# :: Float -> info
, double# :: Double -> info
, other :: info
, depthLimit :: info
}
-- | Runtime representation of Haskell identifier - can be both of type or
-- value.
data Name = Name{
namePkg :: String
, nameMod :: String
, nameId :: String
, nameFixity :: Fixity
} deriving stock Show
-- | 'Name' of given data constructor.
conName :: forall a. Data a => a -> Name
conName a =
Name (tyConPackage tc) (tyConModule tc) (showConstr vc) (constrFixity vc)
where
tc = typeRepTyCon $ typeRep @a
vc = toConstr a
-- | Pretty representation of type at runtime - currently just
-- 'Prelude.String'.
type PrettyType = String
-- | Shows type @a@ as 'PrettyType'.
prettyType :: forall a. Typeable a => PrettyType
prettyType = show $ typeRep @a
-------------------------------------------------------------------------------
-- | Monad for inspecting representation of Haskell values - see 'runRepM'.
newtype RepM a
= RepM{ unRepM :: ReaderT RepOptions (ExceptT String IO) a }
deriving newtype
( Alternative, Applicative, Functor, Monad, MonadIO, MonadError String
, MonadReader RepOptions
)
-- | Options for representation inspection.
data RepOptions = RepOptions{
-- | Depth of inspection - guards against getting stuck in infinite
-- structures.
repDepth :: Natural
-- | Whether inspection should force thunks along the way.
, repStrict :: Bool
-- | Whether printed representations should contain type signatures in
-- ambiguous places - used by 'prettyRep'.
, repTypes :: Bool
} deriving stock Show
-- | Runs action that may make use of inspection of representation of Haskell
-- values (e.g. using 'valueFromData' or 'boxFromAny').
runRepM :: RepM a -> RepOptions -> IO (Either String a)
runRepM = fmap runExceptT . runReaderT . unRepM
-------------------------------------------------------------------------------
-- | Lifted Haskell value together with it's 'Data' instance.
data Value = forall a. Data a => Value a
instance Show Value where
show = either error id . unsafePerformIO .
flip runRepM (RepOptions 100 True False) . prettyRep . Right
-- | Inspects any value with 'Data' instance using given interpretation. Prefer
--- over 'boxFromAny' where possible.
valueFromData :: forall a r. Data a => FromValue Value r -> a -> RepM r
valueFromData FromValue{..} a = flip go a =<< asks repDepth where
go :: forall x. Data x => Natural -> x -> RepM r
go n = fmap <$> box . Value <*> case n of
0 -> \_ -> pure depthLimit
_ -> thunked (\_ -> pure thunk) \x -> case constrRep $ toConstr x of
IntConstr i -> pure $ integral i $ prettyType @x
FloatConstr r -> pure $
floating
case typeRep @x of
Float -> float2Double x
Double -> x
_ -> fromRational r
(prettyType @x)
CharConstr c -> pure $ char c
AlgConstr{} -> case typeOf x of
String -> uncurry string <$> stringRep n x
List -> uncurry list <$> listRep n x
_ -> conOf x . reverse <$>
confoldl (\ys y -> (:) <$> go (n - 1) y <*> ys) (pure []) x
conOf :: forall x. Data x => x -> [r] -> _
conOf x
| '(':_ <- nameId c = tuple
| fs@(_:_) <- constrFields $ toConstr x = rec c . zip fs
| otherwise = con c []
where c = conName x
stringRep :: Natural -> String -> RepM ([Either Value Char], Maybe Value)
stringRep 0 = tailThunk
stringRep n = thunked tailThunk \case
[] -> pure ([], Nothing)
c:cs -> first . (:) <$> thunked' (Left . Value) Right c
<*> stringRep (n - 1) cs
listRep :: forall x. Data [x] => Natural -> [x] -> RepM ([r], Maybe Value)
listRep 0 = tailThunk
listRep n = thunked tailThunk \case
[] -> pure ([], Nothing)
x:xs -> do
-- We don't have 'Data a', so instead we capture first field of (':')
-- with it's instance and ignore the rest
x' <- fromJust $
confoldl (\r y -> r <|> Just (go n y)) Nothing [x]
first (x':) <$> listRep (n - 1) xs
tailThunk :: forall x y. Data x => x -> RepM ([y], Maybe Value)
tailThunk = pure . ([],) . Just . Value
-------------------------------------------------------------------------------
-- | Inspects any lifted value using given interpretation. This function can't
-- recover some information compared to 'valueFromData' - specifically, it
-- never recovers record syntax and unpacked fields are only provided by their
-- representation using 'Word's.
boxFromAny :: forall r a. FromValue Box r -> a -> RepM r
-- TODO: levity polymorphism
boxFromAny FromValue{..} a = flip go a =<< asks repDepth where
go :: forall x. Natural -> x -> RepM r
go = \case
0 -> boxWith depthLimit
d -> thunked (boxWith thunk) \x ->
liftIO (getClosureData x) >>= \case
ConstrClosure{ ptrArgs, dataArgs, pkg, modl, name } ->
box (asBox x) <$> case (pkg, modl, name) of
("ghc-prim", "GHC.Types", n)
| "I#" <- n -> unsafeIntegral @Int x "Int"
| "W#" <- n -> unsafeIntegral @Word x "Word"
| "F#" <- n -> unsafeFloating float2Double x "Float"
| "D#" <- n -> unsafeFloating id x "Double"
| "C#" <- n -> pure $ char (unsafeCoerce# x :: Char)
| n `elem` [":", "[]"] -> boxListRep d ptrArgs
-- TODO: integer-simple
("ghc-prim", "GHC.Tuple", _) ->
tuple <$> for ptrArgs \(Box y) -> go (d - 1) y
("integer-wired-in", "GHC.Integer.Type", n)
| n `elem` ["S#", "Jp#", "Jn#"] ->
unsafeIntegral @Integer x "Integer"
("base", "GHC.Natural", n)
| n `elem` ["NatS#", "NatJ#"] ->
unsafeIntegral @Natural x "Natural"
("base", "GHC.Int", n)
| "I8#" <- n -> unsafeIntegral @Int8 x "Int8"
| "I16#" <- n -> unsafeIntegral @Int16 x "Int16"
| "I32#" <- n -> unsafeIntegral @Int32 x "Int32"
| "I64#" <- n -> unsafeIntegral @Int64 x "Int64"
("base", "GHC.Word", n)
| "W8#" <- n -> unsafeIntegral @Word8 x "Word8"
| "W16#" <- n -> unsafeIntegral @Word16 x "Word16"
| "W32#" <- n -> unsafeIntegral @Word32 x "Word32"
| "W64#" <- n -> unsafeIntegral @Word64 x "Word64"
(_, _, n)
| let fixity = case n of ':':_ -> Infix; _ -> Prefix
boxName = Name pkg modl name fixity ->
con boxName dataArgs <$> for ptrArgs \(Box y) -> go (d - 1) y
IndClosure _ (Box i) -> go (d - 1) i
WeakClosure{ value = Box i } -> go (d - 1) i
MutVarClosure _ (Box i) -> box (asBox x) . mutVar <$> go (d - 1) i
v -> pure $ box (asBox x) case v of
FunClosure{} -> fun
PAPClosure{} -> fun
BCOClosure{} -> bytecode
ArrWordsClosure _ s ws -> byteArray s ws
MutArrClosure{} -> mutByteArray
MVarClosure{} -> mVar
BlockingQueueClosure{} -> stmQueue
IntClosure _ i -> int# i
WordClosure _ w -> word# w
Int64Closure _ i -> int64# i
Word64Closure _ w -> word64# w
AddrClosure _ p -> addr# p
FloatClosure _ f -> float# f
DoubleClosure _ f -> double# f
_ -> other
boxWith :: forall x. _ -> x -> RepM r
boxWith r b = pure $ box (asBox b) r
unsafeIntegral :: forall x b. Integral x => b -> PrettyType -> RepM _
unsafeIntegral i = pure . integral (toInteger (unsafeCoerce# i :: x))
unsafeFloating :: forall y x. (x -> Double) -> y -> PrettyType -> RepM _
unsafeFloating f d = pure . floating (f (unsafeCoerce# @_ @_ @y @x d))
boxListRep :: Natural -> [Box] -> RepM _
boxListRep d = goList d False id where
goList _ isStr acc [] =
mkList isStr (acc []) Nothing
goList 0 isStr acc [x, xs] = mkList isStr (acc [x]) $ Just xs
goList n isStr acc [Box x, Box xs] = do
isChar <- thunked (\_ -> pure False)
do liftIO . getClosureData >>> fmap \case
CharClosure -> True
_ -> False
x
thunked
do mkList (isStr || isChar) (acc [asBox x]) . Just . asBox
do liftIO . getClosureData >=> \case
ConstrClosure{ ptrArgs } ->
goList (n - 1) (isStr || isChar) (acc . (asBox x :)) ptrArgs
_ -> invalidList
xs
goList _ _ _ _ = invalidList
invalidList :: HasCallStack => z
invalidList = withFrozenCallStack $
error "Heap.Console.Inspector.boxListRep: invalid list"
mkList False xs t = flip list t <$>
for (zip [d, d - 1 .. 0] xs) \(n, Box x) -> go n x
mkList True xs t = flip string t <$> for xs \(Box c) ->
thunked' (Left . Box) (Right . id @Char . unsafeCoerce#) c
-------------------------------------------------------------------------------
-- | Indexes Haskell value using given "selection" - that is, 'Bool'
-- determining whether indexing should be always strict and list of indexes to
-- walk through along the way. Valid indexes are:
--
-- * positive integer (e.g. @3@) - position of element in list, tuple or other
-- data constructor
--
-- * record field name (e.g. @foo@) - name of field in record (only works when
-- given enough information - that is, with 'Value' as input)
--
-- In case of 'Box', unpacked values are ignored while indexing.
index :: Either Box Value -> Bool -> [String] -> RepM (Either Box Value)
index a strict fs' = local (\o -> o{ repStrict = strict || repStrict o } ) $
bitraverse
(\(Box x) -> ($ fs') =<< boxFromAny FromValue{..} x)
(\(Value v) -> ($ fs') =<< valueFromData FromValue{..} v)
a
where
withIndexes
:: ([String] -> String -> RepM b) -> b -> [String] -> RepM b
withIndexes _ b [] = pure b
withIndexes g _ (f:fs) = g fs f
withList
:: [[String] -> RepM b]
-> Maybe b
-> b -> [String] -> RepM b
withList xs t = withIndexes \fs -> \case
s | Just i <- readMaybe @Natural s ->
case (drop (fromIntegral i) xs, t) of
(x:_, _) -> x fs
([], Nothing) -> throwError $ "index '" ++ s ++ "' out of range"
([], Just{}) -> throwError $
"index '" ++ s ++ "' not yet evaluated, try using '!'"
| otherwise -> throwError $
"expected positive integer as index, found '" ++ s ++ "'"
notIndexable :: String -> b -> [String] -> RepM b
notIndexable _ b [] = pure b
notIndexable msg _ fs = throwError $
"unexpected indexing '." ++ intercalate "." fs ++ "' of " ++ msg
box = (&)
list = withList
-- TODO: make indexable
string _ _ = notIndexable "'String'"
char _ = notIndexable "'Char'"
tuple = flip withList Nothing
con _ _ = flip withList Nothing
rec _ xs b is =
withList (snd <$> xs) Nothing b is `catchError` \_ ->
withIndexes goRec b is
where
goRec fs f = case lookup f xs of
Nothing -> throwError $ "no index or field '" ++ f ++ "' found"
Just x -> x fs
fun = notIndexable "a function"
thunk = notIndexable "a thunk - try using '!'"
bytecode = notIndexable "bytecode"
byteArray _ _ = notIndexable "'ByteArray#' - currently not supported"
mutByteArray = notIndexable "'MutableByteArray#' - currently not supported"
mVar = notIndexable "'MVar#' - currently not supported"
mutVar r _ fs = r fs
stmQueue = notIndexable "a STM queue"
integral _ _ = notIndexable "an integral number"
floating _ _ = notIndexable "an floating number"
int# _ = notIndexable "'Int#'"
word# _ = notIndexable "'Word#'"
int64# _ = notIndexable "'Int64#'"
word64# _ = notIndexable "'Word64#'"
addr# _ = notIndexable "an address"
float# _ = notIndexable "'Float#'"
double# _ = notIndexable "'Double#'"
other = notIndexable "an unknown value"
depthLimit = notIndexable "a value after depth limit - try using '!'"
-------------------------------------------------------------------------------
-- | Pretty-print given value. In case of 'Box', record syntax is never shown
-- and (unpacked) fields may be shown as 'Word#'s out of order.
prettyRep :: Either Box Value -> RepM String
prettyRep a = ask >>= go where
go RepOptions{..} = do
pretty <- case a of
Left (Box x) -> boxFromAny FromValue{..} x
Right (Value v) -> valueFromData FromValue{..} v
pure $ pretty -1 ""
where
-- NOTE: 'dataToHsRep' does forcing, so don't bother with forcing of thunks
-- during printing.
signature :: Show b => b -> String -> PrecShowS
signature b t = if repTypes
then showInfix "::" -1 (precShow b) \_ -> (t ++)
else precShow b
postfix :: Show b => String -> b -> PrecShowS
postfix p b _ = shows b . (p ++)
precShow :: Show b => b -> PrecShowS
precShow = flip showsPrec
intercalateS :: String -> [ShowS] -> ShowS
intercalateS _ [] = id
intercalateS _ [x] = x
intercalateS s (x:xs) = x . (s ++) . intercalateS s xs
box _ = id
list xs t _ = ('[':)
. intercalateS ", " (xs <&> ($ -1))
. ((++) if isJust t then ", .." else "")
. (']':)
string cs t _ = ('"':)
. foldl' (.) id (either (\_ -> ("\"_\"" ++)) (:) <$> cs)
. ('"':)
. (++) if isJust t then ".." else ""
char = precShow
tuple xs _ = ('(':)
. intercalateS ", " (xs <&> ($ -1))
. (')':)
con n@Name{..} ws xs = case nameFixity of
Prefix -> foldl'
showApp
(foldl' showApp (showCon nameId) $ postfix "##" <$> ws)
xs
Infix -> case (postfix "##" <$> ws) ++ xs of
[] -> const (showParen True (nameId ++))
[x] -> const (showParen True (nameId ++)) `showApp` x
[x, y] -> showInfix nameId 9 x y
x:y:ys -> foldl' showApp (con n [] [x, y]) ys
rec Name{..} = showRecord n . \case
[] -> noFields
xs -> foldl1' (&|) $ uncurry showField <$> xs
where
n = case nameFixity of
Infix -> '(' : nameId ++ ")"
Prefix -> nameId
fun p = showParen (p > -1) ("\\_ -> _" ++)
thunk = showCon "_"
bytecode = showCon "_bytecode"
byteArray _ ws p = list (postfix "#" <$> ws) Nothing p . ('#':)
mutByteArray = showCon "_mutByteArray"
mVar = showCon "_mVar"
mutVar = showApp $ showCon "MutVar#"
stmQueue = showCon "_stmQueue"
integral = signature
floating = signature
int# = postfix "#"
word# = postfix "##"
int64# = postfix "L#"
word64# = postfix "L##"
addr# (I# i) = precShow $ unpackCString# (unsafeCoerce# i)
float# = postfix "#"
double# = postfix "##"
other = showCon "_unknown"
depthLimit = showCon ".."
-------------------------------------------------------------------------------
-- | Branches on presence of thunk - in @thunked tf ntf@, @tf@ runs when value
-- is a thunk and @ntf@ when it isn't. When 'repStrict' is set, 'thunked' will
-- instead always force the value and pass it to @ntf@.
thunked :: (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked tf ntf a = asks repStrict >>= \case
False -> isThunk a >>= bool (ntf a) (tf a)
True -> a `seq'` ntf a
-- | Version of 'thunked' taking pure functions.
thunked' :: (a -> b) -> (a -> b) -> a -> RepM b
thunked' tf ntf = thunked (pure . tf) (pure . ntf)
-- | Tests whether value is a thunk - that is, any type of closure that can be
-- considered one.
isThunk :: MonadIO m => a -> m Bool
isThunk = liftIO . getClosureData >>> fmap \case
ThunkClosure{} -> True
SelectorClosure{} -> True
APClosure{} -> True
APStackClosure{} -> True
BlackholeClosure{} -> True
_ -> False
-- | Version of 'seq' that blocks until it's first argument is forced.
seq' :: a -> b -> b
-- TODO: 'performGC' is used to speed up forcing in GHCi, where it seems to
-- otherwise get stuck for dozens of seconds under blackhole - investigate
-- ways of resolving the issue without visibly slowing down whole operation.
seq' a = seq $ unsafePerformIO $ evaluate a *> performGC *> whileM (isThunk a)
{-# noinline seq' #-}
-------------------------------------------------------------------------------
-- | Equivalent of 'foldl' for data constructors, providing opaque fields
-- with their 'Data' instance along the way.
confoldl :: Data a => (forall b. Data b => r -> b -> r) -> r -> a -> r
confoldl c n = getConst . gfoldl
do \(Const acc) -> Const . c acc
do \_ -> Const n
-------------------------------------------------------------------------------
-- | Repeatedly evaluates provided action until it yields 'False'.
whileM :: Monad m => m Bool -> m ()
whileM mb = bool (pure ()) (whileM mb) =<< mb
-------------------------------------------------------------------------------
-- | Tests equality of @a@ to @b@ described by given 'TypeRep'.
isType :: forall a b. Typeable a => TypeRep b -> Maybe (a :~~: b)
isType = eqTypeRep typeRep
-- | Proof of @a@ being equal to @f b@ for some @b@.
data IsCon f a = forall b. a ~ f b => IsCon
-- | Tests whether @a@ described by given 'TypeRep' is equal to @f b@ for some
-- @b@.
isCon :: forall f a. Typeable f => TypeRep a -> Maybe (IsCon f a)
isCon = \case
App l _ | Just HRefl <- eqTypeRep l $ typeRep @f -> Just IsCon
_ -> Nothing
pattern Float :: () => a ~ Float => TypeRep a
pattern Float <- (isType @Float -> Just HRefl)
pattern Double :: () => a ~ Double => TypeRep a
pattern Double <- (isType @Double -> Just HRefl)
pattern String :: () => a ~ String => TypeRep a
pattern String <- (isType @String -> Just HRefl)
pattern List :: () => a ~ [b] => TypeRep a
pattern List <- (isCon @[] -> Just IsCon)
-------------------------------------------------------------------------------
pattern CharClosure :: GenClosure a
pattern CharClosure <-
ConstrClosure{ pkg = "ghc-prim", modl = "GHC.Types", name = "C#" }