{-# 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#" }