heap-console (empty) → 0.1.0.0
raw patch · 7 files changed
+1210/−0 lines, 7 filesdep +basedep +containersdep +exceptions
Dependencies added: base, containers, exceptions, ghc-heap, ghc-prim, haskeline, heap-console, hspec, mtl, show-combinators
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +62/−0
- heap-console.cabal +64/−0
- src/Heap/Console.hs +496/−0
- src/Heap/Console/Value.hs +552/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for heap-console++## 0.1.0.0 -- 2020-11-20++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, TheMatten++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of TheMatten nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,62 @@+# `heap-console` 🔎++> Debugging - the classic mystery game where you are the detective, the victim,+> and the murderer!+>+> *Some poor developer*++Quite a common approach in Haskell for debugging programs is to use+`Debug.Trace` - problem is that what we often want to do is not to print random+strings, but to inspect the state of the program. Debuggers are meant for this,+but they can be tricky to set up, may require speicific graphical tools to be+somewhat convenient, and it's easy to forget to run your program through one+while iterating through changes in code.++`heap-console` let's you inspect your values at runtime using simple+combinators, resuming execution once you close it:++```txt+> import Heap.Console+> inspect (42, 'a')+[Entering heap-view - use `:help` for more information]+heap-console> it+(_, 'a')+heap-console> !it+(42, 'a')+heap-console> it.1+'a'+heap-console> :exit+[Exiting heap-view]+(42, 'a')+```++If you give it `Data` instance, it can recognize records too:++```txt+> :set -XDeriveDataTypeable+> data Foo = Foo{ bar :: Int, baz :: String } deriving Data+> inspectAD $ Foo 65 "Hello World!"+[Entering heap-view - use `:help` for more information]+heap-console> !it+Foo {bar = 65, baz = "Hello World!"}+heap-console> it.baz+"Hello World!"+heap-console> ^D+[Exiting heap-view]+```++And you can bind values for inspection in random places, getting to them once+it makes sense:++```txt+> evidenceD "foo" [1,2,3]+> inspection+[Entering heap-view - use `:help` for more information]+heap-console> foo+[1, 2, 3]+heap-console> ^D+[Exiting heap-view]+```++To see more features, take a look at documentation, or simply try `:help`+command.
+ heap-console.cabal view
@@ -0,0 +1,64 @@+cabal-version: 2.4+name: heap-console+version: 0.1.0.0+synopsis: interactively inspect Haskell values at runtime+description: See the README.md file in the project repository.+homepage: https://gitlab.com/thematten/heap-console+bug-reports: https://gitlab.com/thematten/heap-console/issues+license: BSD-3-Clause+license-file: LICENSE+author: TheMatten+maintainer: matten@tuta.io++copyright: 2020 TheMatten+category: Language+extra-source-files: CHANGELOG.md README.md++source-repository head+ type: git+ location: git://gitlab.com/thematten/heap-console.git++common common+ build-depends: base ^>=4.14.1.0+ default-extensions: BangPatterns+ BlockArguments+ DeriveAnyClass+ DerivingStrategies+ FlexibleContexts+ GADTs+ GeneralizedNewtypeDeriving+ KindSignatures+ LambdaCase+ NamedFieldPuns+ NegativeLiterals+ PartialTypeSignatures+ PatternSynonyms+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeOperators+ ViewPatterns+ default-language: Haskell2010+ ghc-options: -Wall -Wno-partial-type-signatures++library+ import: common+ build-depends: exceptions ^>=0.10.4+ , containers ^>=0.6.2.1+ , haskeline ^>=0.8.1+ , ghc-heap ^>=8.10.2+ , ghc-prim ^>=0.6.1+ , mtl ^>=2.2.2+ , show-combinators ^>=0.2+ exposed-modules: Heap.Console Heap.Console.Value+ hs-source-dirs: src++test-suite heap-console-test+ import: common+ build-depends: heap-console, hspec ^>=2.7.4+ build-tool-depends: hspec-discover:hspec-discover ^>=2.7.4+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs
+ src/Heap/Console.hs view
@@ -0,0 +1,496 @@+{-# language AllowAmbiguousTypes #-}++-- | This module provides combinators for spawning heap console in convenient+-- way.+--+-- = Console usage+--+-- Console startup is indicated by a message:+--+-- @+-- [Entering heap-view - use `:help` for more information]+-- @+--+-- followed by console's prompt:+--+-- @+-- heap-console>+-- @+--+-- here you can probe for values of bindings or use provided commands - e.g.+-- when opening console with:+--+-- @+-- inspect (42, \'a\')+-- @+--+-- you can inspect given value under name @it@:+--+-- @+-- heap-console> it+-- (_, \'a\')+-- @+--+-- or see the value strictly evaluated (up to the configured depth):+--+-- @+-- heap-console> !it+-- (42, \'a\')+-- @+--+-- or you can access it's parts by using selection:+--+-- @+-- heap-console> it.1+-- \'a\'+-- @+--+-- __Bindings__ can be automatically created with functions like 'inspectD',+-- added in arbitrary places in program using e.g. 'evidenceD' or added in+-- console directly by assigning results of selections:+--+-- @+-- heap-console> foo = bar.0.baz+-- @+--+-- __Selections__ consist of sequence of dot-separated indexes, optionally+-- prefixed with @!@ to force thunks 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, when value has 'Data' instance+-- available)+--+-- In general, it's recommended to prefer combinators suffixed with @D@ when+-- possible - they require 'Data' instance for bindings being added, but+-- provide ability to recover record syntax and information about unpacked+-- fields - in case of combinators without @D@, unpacked fields appear as plain+-- @Word#@s without any information about their origin and are not indexable.+-- 'Data' instances can be easily derived using @-XDeriveDataTypeable@.+module Heap.Console+ {-# warning+ "\"heap-console\" is meant for debugging only\+ \ - make sure you remove it in production."+ #-}+ ( inspect+ , inspectD+ , inspecting+ , inspectingD+ , inspectA+ , inspectAD+ , investigate+ , investigateD+ , inspection+ , withInspection+ , investigation+ , withEvidence+ , withEvidenceD+ , evidence+ , evidenceD+ ) where++import Control.Arrow hiding (first, second)+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.State.Strict+import Data.Bifunctor+import Data.Char+import Data.Data+import Data.Function+import Data.Functor+import Data.IORef+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Foldable+import GHC.Exts.Heap+import GHC.Stack+import Heap.Console.Value+import System.Console.Haskeline+import System.IO.Unsafe+import Text.Read (readMaybe)++-- TODO: some persistent configuration?+-- TODO: implement auto-completion.++-------------------------------------------------------------------------------+-- | Opens console for inspecting argument before returning it. Argument is+-- provided in console under name @it@.+--+-- >>> inspect 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- 42+inspect :: a -> a+inspect = join inspecting++-- | Version of 'inspect' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> inspectD 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- 42+inspectD :: Data a => a -> a+inspectD = join inspectingD++-- | Opens console for inspecting @a@ before returning @b@. Argument @a@ is+-- provided in console under name @it@.+--+-- >>> inspecting 42 'a'+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- 'a'+inspecting :: a -> b -> b+inspecting = inspectingSome . Left . asBox++-- | Version of 'inspecting' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> inspectingD 42 'a'+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- 'a'+inspectingD :: Data a => a -> b -> b+inspectingD = inspectingSome . Right . Value++inspectingSome :: Either Box Value -> b -> b+inspectingSome v = seq $ unsafePerformIO do+ c <- consoleWithEvidence+ heapConsole c{ consoleBinds = M.insert "it" v $ consoleBinds c }+{-# noinline inspectingSome #-}++-- | Opens console for inspecting argument. Argument is provided in console+-- under name @it@.+--+-- >>> inspectA 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+inspectA :: Applicative f => a -> f ()+inspectA a = inspecting a $ pure ()++-- | Version of 'inspectA' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> inspectAD 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+inspectAD :: (Data a, Applicative f) => a -> f ()+inspectAD a = inspectingD a $ pure ()++-- | Opens console for inspecting argument before failing with error. Argument+-- is provided in console under name @it@.+--+-- >>> investigate 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- *** Exception: Heap.Console.investigate: closed investigation+-- CallStack (from HasCallStack):+-- investigate, called at <interactive>:1:1 in interactive:Ghci+investigate :: HasCallStack => a -> b+investigate a = withFrozenCallStack $ inspecting a $+ error "Heap.Console.investigate: closed investigation"++-- | Version of 'investigate' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> investigateD 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- *** Exception: Heap.Console.investigateD: closed investigation+-- CallStack (from HasCallStack):+-- investigateD, called at <interactive>:1:1 in interactive:Ghci+investigateD :: (HasCallStack, Data a) => a -> b+investigateD a = withFrozenCallStack $ inspectingD a $+ error "Heap.Console.investigateD: closed investigation"++-- | Opens console with recorded "evidence" in scope.+--+-- >>> inspection+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+inspection :: Applicative f => f ()+inspection = withInspection $ pure ()++-- | Opens console with recorded "evidence" in scope, before returning given+-- argument.+--+-- >>> withInspection 42+-- [Entering heap-view - use `:help` for more information]+-- ...+-- [Exiting heap-view]+-- 42+withInspection :: a -> a+withInspection a =+ -- NOTE: do not eta reduce - GHC seems to memoize it as CAF in that case.+ unsafePerformIO (heapConsole =<< consoleWithEvidence) `seq` a+{-# noinline withInspection #-}++-- | Opens console with recorded "evidence" in scope before failing with error.+--+-- >>> investigation+-- [Entering heap-view - use `:help` for more information]+-- heap-console>+-- [Exiting heap-view]+-- *** Exception: Heap.Console.investigation: closed investigation+-- CallStack (from HasCallStack):+-- investigation, called at <interactive>:1:1 in interactive:Ghci+investigation :: HasCallStack => a+investigation = withFrozenCallStack $ withInspection $+ error "Heap.Console.investigation: closed investigation"++-- | Records @a@ as "evidence" to be later provided in console under given+-- name, before returning @b@.+--+-- >>> withEvidence "foo" 'a' inspection+-- [Entering heap-view - use `:help` for more information]+-- heap-console> foo+-- 'a'+-- ...+-- [Exiting heap-view]+withEvidence :: String -> a -> b -> b+withEvidence n = withSomeEvidence n . Left . asBox++-- | Version of 'withEvidence' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> withEvidenceD "foo" 'a' inspection+-- [Entering heap-view - use `:help` for more information]+-- heap-console> foo+-- 'a'+-- ...+-- [Exiting heap-view]+withEvidenceD :: Data a => String -> a -> b -> b+withEvidenceD n = withSomeEvidence n . Right . Value++-- | Records @a@ as "evidence" to be later provided in console under given+-- name.+--+-- >>> evidence "foo" 42+-- >>> inspection+-- [Entering heap-view - use `:help` for more information]+-- heap-console> foo+-- 42+-- ...+-- [Exiting heap-view]+evidence :: Applicative f => String -> a -> f ()+evidence n v = withEvidence n v $ pure ()++-- | Version of 'evidence' providing more precise inspection using 'Data' -+-- prefer this one where possible.+--+-- >>> evidenceD "foo" 42+-- >>> inspection+-- [Entering heap-view - use `:help` for more information]+-- heap-console> foo+-- 42+-- ...+-- [Exiting heap-view]+evidenceD :: (Data a, Applicative f) => String -> a -> f ()+evidenceD n v = withEvidenceD n v $ pure ()++-------------------------------------------------------------------------------+withSomeEvidence :: String -> Either Box Value -> a -> a+withSomeEvidence n v = seq $ unsafePerformIO $ addEvidence n v++consoleWithEvidence :: IO Console+consoleWithEvidence = readIORef unsafeCollectedEvidence <&> \consoleBinds ->+ defaultConsole{ consoleBinds }++addEvidence :: String -> Either Box Value -> IO ()+addEvidence n v =+ atomicModifyIORef' unsafeCollectedEvidence $ (,()) . M.insert n v++unsafeCollectedEvidence :: IORef (Map String (Either Box Value))+unsafeCollectedEvidence = unsafePerformIO $ newIORef M.empty+{-# noinline unsafeCollectedEvidence #-}++-------------------------------------------------------------------------------+newtype ConsoleM a = ConsoleM{ unConsoleM :: StateT Console (InputT IO) a }+ deriving newtype+ ( Applicative, Functor, Monad, MonadCatch, MonadIO, MonadMask+ , MonadState Console, MonadThrow+ )++data Console = Console{+ consoleRepOptions :: RepOptions+ , consolePrompt :: String+ , consoleBinds :: Map String (Either Box Value)+ } deriving stock Show++defaultConsole :: Console+defaultConsole = Console (RepOptions 16 False False) "heap-console> " M.empty++data ConsoleExit = ConsoleExit+ deriving stock Show+ deriving anyclass Exception++runConsoleM :: Console -> ConsoleM a -> IO (Maybe a)+runConsoleM c = handle (\ConsoleExit -> pure Nothing) . fmap Just+ . runInputT defaultSettings . flip evalStateT c . unConsoleM++exitConsole :: ConsoleM a+exitConsole = throwM ConsoleExit++liftRepM :: RepM a -> ConsoleM (Either String a)+liftRepM ma = ConsoleM $ liftIO . runRepM ma =<< gets consoleRepOptions++withRepM :: RepM a -> (a -> ConsoleM ()) -> ConsoleM ()+withRepM ma f = liftRepM ma >>= either errorC f++putStrLnC :: String -> ConsoleM ()+putStrLnC = ConsoleM . lift . outputStrLn++getLnC :: ConsoleM String+getLnC = maybe exitConsole pure =<< ConsoleM do+ lift . getInputLine =<< gets consolePrompt++errorC :: String -> ConsoleM ()+errorC = ConsoleM . lift . outputStrLn . ("error: " ++)++catchInterrupt :: ConsoleM () -> ConsoleM ()+catchInterrupt (ConsoleM ma) =+ handleInterrupt (pure ()) $ ConsoleM $ mapStateT withInterrupt ma++heapConsole :: Console -> IO ()+heapConsole c = do+ putStrLn "[Entering heap-view - use `:help` for more information]"+ _ <- runConsoleM c $ forever $ catchInterrupt $+ either errorC commands . parseCommand =<< getLnC+ putStrLn "[Exiting heap-view]"++commands :: [String] -> ConsoleM ()+commands = \case+ [] -> pure ()++ ":help":_ -> putStrLnC+ -- TODO: move descriptions of options to 'Option'?+ "Usage:\n\+ \ :help - shows this text.\n\+ \ :exit | :quit | <ctrl-D> - returns back to program.\n\+ \ :show [OPTION] - shows value of a selected option, or values of all\n\+ \ options if not given any. Available options:\n\+ \ depth :: Natural\n\+ \ depth of printed representation\n\+ \ showTypes :: Bool\n\+ \ whether to show types in printed representation\n\+ \ prompt :: String\n\+ \ console prompt\n\+ \ strict :: Bool\n\+ \ whether inspection should always force values along the way\n\+ \\n\+ \ :set OPTION VALUE - changes option to given value.\n\+ \ NAME = SELECTION - binds result of SELECTION to NAME.\n\+ \ [!]SELECTION - prints selection [strictly].\n\+ \ :info SELECTION - prints info about selected value.\n\+ \ :binds - lists bindings in scope."++ ":exit":_ -> exitConsole+ ":quit":_ -> exitConsole++ ":show":o:_ -> withOption o \l -> putStrLnC . view l =<< get+ ":show":[] -> for_ (M.toList options) \(o, l) ->+ putStrLnC . (++) (o ++ " = ") . view l =<< get+ ":show":_ -> errorC "expecting option name or no argument in `:show`"++ ":set":o:v:_ -> withOption o \l -> case set l v of+ Nothing -> errorC $ "invalid value for option `" ++ o ++ "`"+ Just f -> modify f+ ":set":_ -> errorC "expecting option name and value in `:set`"++ ":info":s:_ -> withSelected s $+ putStrLnC . show <=< liftIO .+ either getBoxedClosureData (\(Value v) -> getClosureData v)+ ":info":_ -> errorC "expecting selection in `:info`"++ ":binds":[] -> gets consoleBinds >>= traverse_ putStrLnC . M.keys+ ":binds":_ -> errorC "expecting no arguments in `:binds`"++ c@(':':_):_ -> errorC $ "unknown command `" ++ c ++ "`"++ n:"=":s:_+ | isIdentifier n -> withSelected s \v -> modify \c ->+ c{ consoleBinds = M.insert n v $ consoleBinds c }+ | otherwise -> errorC $ "`" ++ n ++ "` isn't valid binding name"++ s:[] -> withSelected s \v -> withRepM (prettyRep v) putStrLnC++ _ -> errorC "couldn't parse input"++parseCommand :: String -> Either String [String]+parseCommand = goSpaced where+ goSpaced = \case+ [] -> Right []+ cs -> do+ (x, cs') <- goLexeme False (dropWhile isSpace cs)+ (x :) <$> goSpaced cs'+ goLexeme q = \case+ "" | not q -> Right ([], [])+ | otherwise -> Left "unexpected end of line, expected quote '\"'"+ '\\':'"':cs -> first ('"':) <$> goLexeme q cs+ '"':cs -> goLexeme (not q) cs+ ' ':cs | not q -> Right ([], cs)+ c:cs -> first (c:) <$> goLexeme q cs++parseSelection :: String -> Either String (Bool, String, [String])+parseSelection = \case+ '!':cs -> uncurry (True,,) <$> go cs+ cs -> uncurry (False,,) <$> go cs+ where+ go = groupBy (\_ c -> c /= '.') >>> \case+ [] -> Left "missing selection"+ n:is -> Right (n, tail <$> is)++isIdentifier :: String -> Bool+isIdentifier = \case+ [] -> False+ c:cs -> (isAlpha c || c == '_') && all ((||) <$> isAlphaNum <*> (== '_')) cs++withBind :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()+withBind n f = maybe (errorC $ "binding `" ++ n ++ "` not in scope") f .+ M.lookup n =<< gets consoleBinds++withSelected :: String -> (Either Box Value -> ConsoleM ()) -> ConsoleM ()+withSelected s f = parseSelection s & either errorC \(strict, n, is) ->+ withBind n \v -> withRepM (index v strict is) f++withOption :: String -> (Option Console -> ConsoleM ()) -> ConsoleM ()+withOption o f =+ maybe (errorC $ "there's no option `" ++ o ++ "`") f $ M.lookup o options++options :: Map String (Option Console)+options = M.fromList+ [ ( "depth"+ , option (repDepth . consoleRepOptions) \repDepth c ->+ c{ consoleRepOptions = (consoleRepOptions c){ repDepth } }+ )+ , ( "showTypes"+ , option (repTypes . consoleRepOptions) \repTypes c ->+ c{ consoleRepOptions = (consoleRepOptions c){ repTypes } }+ )+ , ( "prompt"+ , Option (show . consolePrompt) \consolePrompt ->+ Just \c -> c{ consolePrompt }+ )+ , ( "strict"+ , option (repStrict . consoleRepOptions) \repStrict c ->+ c{ consoleRepOptions = (consoleRepOptions c){ repStrict } }+ )+ ]++-------------------------------------------------------------------------------+data Option a = Option{ view :: a -> String, set :: String -> Maybe (a -> a) }++option :: (Show a, Read a) => (x -> a) -> (a -> x -> x) -> Option x+option f t = Option (show . f) $ fmap t . readMaybe
+ src/Heap/Console/Value.hs view
@@ -0,0 +1,552 @@+{-# 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 a . reverse <$>+ confoldl (\ys y -> (:) <$> go (n - 1) y <*> ys) (pure []) a++ 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#" }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}