{-# 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{
    Name -> String
namePkg    :: String
  , Name -> String
nameMod    :: String
  , Name -> String
nameId     :: String
  , Name -> Fixity
nameFixity :: Fixity
  } deriving stock Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show

-- | 'Name' of given data constructor.
conName :: forall a. Data a => a -> Name
conName :: a -> Name
conName a
a =
  String -> String -> String -> Fixity -> Name
Name (TyCon -> String
tyConPackage TyCon
tc) (TyCon -> String
tyConModule TyCon
tc) (Constr -> String
showConstr Constr
vc) (Constr -> Fixity
constrFixity Constr
vc)
 where
  tc :: TyCon
tc = TypeRep a -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep a -> TyCon) -> TypeRep a -> TyCon
forall a b. (a -> b) -> a -> b
$ Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a
  vc :: Constr
vc = a -> Constr
forall a. Data a => a -> Constr
toConstr a
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 :: String
prettyType = TypeRep a -> String
forall a. Show a => a -> String
show (TypeRep a -> String) -> TypeRep a -> String
forall a b. (a -> b) -> a -> b
$ Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a

-------------------------------------------------------------------------------
-- | Monad for inspecting representation of Haskell values - see 'runRepM'.
newtype RepM a
  = RepM{ RepM a -> ReaderT RepOptions (ExceptT String IO) a
unRepM :: ReaderT RepOptions (ExceptT String IO) a }
  deriving newtype
    ( Applicative RepM
RepM a
Applicative RepM
-> (forall a. RepM a)
-> (forall a. RepM a -> RepM a -> RepM a)
-> (forall a. RepM a -> RepM [a])
-> (forall a. RepM a -> RepM [a])
-> Alternative RepM
RepM a -> RepM a -> RepM a
RepM a -> RepM [a]
RepM a -> RepM [a]
forall a. RepM a
forall a. RepM a -> RepM [a]
forall a. RepM a -> RepM a -> RepM a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: RepM a -> RepM [a]
$cmany :: forall a. RepM a -> RepM [a]
some :: RepM a -> RepM [a]
$csome :: forall a. RepM a -> RepM [a]
<|> :: RepM a -> RepM a -> RepM a
$c<|> :: forall a. RepM a -> RepM a -> RepM a
empty :: RepM a
$cempty :: forall a. RepM a
$cp1Alternative :: Applicative RepM
Alternative, Functor RepM
a -> RepM a
Functor RepM
-> (forall a. a -> RepM a)
-> (forall a b. RepM (a -> b) -> RepM a -> RepM b)
-> (forall a b c. (a -> b -> c) -> RepM a -> RepM b -> RepM c)
-> (forall a b. RepM a -> RepM b -> RepM b)
-> (forall a b. RepM a -> RepM b -> RepM a)
-> Applicative RepM
RepM a -> RepM b -> RepM b
RepM a -> RepM b -> RepM a
RepM (a -> b) -> RepM a -> RepM b
(a -> b -> c) -> RepM a -> RepM b -> RepM c
forall a. a -> RepM a
forall a b. RepM a -> RepM b -> RepM a
forall a b. RepM a -> RepM b -> RepM b
forall a b. RepM (a -> b) -> RepM a -> RepM b
forall a b c. (a -> b -> c) -> RepM a -> RepM b -> RepM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: RepM a -> RepM b -> RepM a
$c<* :: forall a b. RepM a -> RepM b -> RepM a
*> :: RepM a -> RepM b -> RepM b
$c*> :: forall a b. RepM a -> RepM b -> RepM b
liftA2 :: (a -> b -> c) -> RepM a -> RepM b -> RepM c
$cliftA2 :: forall a b c. (a -> b -> c) -> RepM a -> RepM b -> RepM c
<*> :: RepM (a -> b) -> RepM a -> RepM b
$c<*> :: forall a b. RepM (a -> b) -> RepM a -> RepM b
pure :: a -> RepM a
$cpure :: forall a. a -> RepM a
$cp1Applicative :: Functor RepM
Applicative, a -> RepM b -> RepM a
(a -> b) -> RepM a -> RepM b
(forall a b. (a -> b) -> RepM a -> RepM b)
-> (forall a b. a -> RepM b -> RepM a) -> Functor RepM
forall a b. a -> RepM b -> RepM a
forall a b. (a -> b) -> RepM a -> RepM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RepM b -> RepM a
$c<$ :: forall a b. a -> RepM b -> RepM a
fmap :: (a -> b) -> RepM a -> RepM b
$cfmap :: forall a b. (a -> b) -> RepM a -> RepM b
Functor, Applicative RepM
a -> RepM a
Applicative RepM
-> (forall a b. RepM a -> (a -> RepM b) -> RepM b)
-> (forall a b. RepM a -> RepM b -> RepM b)
-> (forall a. a -> RepM a)
-> Monad RepM
RepM a -> (a -> RepM b) -> RepM b
RepM a -> RepM b -> RepM b
forall a. a -> RepM a
forall a b. RepM a -> RepM b -> RepM b
forall a b. RepM a -> (a -> RepM b) -> RepM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> RepM a
$creturn :: forall a. a -> RepM a
>> :: RepM a -> RepM b -> RepM b
$c>> :: forall a b. RepM a -> RepM b -> RepM b
>>= :: RepM a -> (a -> RepM b) -> RepM b
$c>>= :: forall a b. RepM a -> (a -> RepM b) -> RepM b
$cp1Monad :: Applicative RepM
Monad, Monad RepM
Monad RepM -> (forall a. IO a -> RepM a) -> MonadIO RepM
IO a -> RepM a
forall a. IO a -> RepM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> RepM a
$cliftIO :: forall a. IO a -> RepM a
$cp1MonadIO :: Monad RepM
MonadIO, MonadError String
    , MonadReader RepOptions
    )

-- | Options for representation inspection.
data RepOptions = RepOptions{
    -- | Depth of inspection - guards against getting stuck in infinite
    -- structures.
    RepOptions -> Natural
repDepth  :: Natural
    -- | Whether inspection should force thunks along the way.
  , RepOptions -> Bool
repStrict :: Bool
    -- | Whether printed representations should contain type signatures in
    -- ambiguous places - used by 'prettyRep'.
  , RepOptions -> Bool
repTypes  :: Bool
  } deriving stock Int -> RepOptions -> ShowS
[RepOptions] -> ShowS
RepOptions -> String
(Int -> RepOptions -> ShowS)
-> (RepOptions -> String)
-> ([RepOptions] -> ShowS)
-> Show RepOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepOptions] -> ShowS
$cshowList :: [RepOptions] -> ShowS
show :: RepOptions -> String
$cshow :: RepOptions -> String
showsPrec :: Int -> RepOptions -> ShowS
$cshowsPrec :: Int -> RepOptions -> ShowS
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 :: RepM a -> RepOptions -> IO (Either String a)
runRepM = (ExceptT String IO a -> IO (Either String a))
-> (RepOptions -> ExceptT String IO a)
-> RepOptions
-> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExceptT String IO a -> IO (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((RepOptions -> ExceptT String IO a)
 -> RepOptions -> IO (Either String a))
-> (RepM a -> RepOptions -> ExceptT String IO a)
-> RepM a
-> RepOptions
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT RepOptions (ExceptT String IO) a
-> RepOptions -> ExceptT String IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT RepOptions (ExceptT String IO) a
 -> RepOptions -> ExceptT String IO a)
-> (RepM a -> ReaderT RepOptions (ExceptT String IO) a)
-> RepM a
-> RepOptions
-> ExceptT String IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepM a -> ReaderT RepOptions (ExceptT String IO) a
forall a. RepM a -> ReaderT RepOptions (ExceptT String IO) a
unRepM

-------------------------------------------------------------------------------
-- | Lifted Haskell value together with it's 'Data' instance.
data Value = forall a. Data a => Value a

instance Show Value where
  show :: Value -> String
show = ShowS -> ShowS -> Either String String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ShowS
forall a. HasCallStack => String -> a
error ShowS
forall a. a -> a
id (Either String String -> String)
-> (Value -> Either String String) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either String String) -> Either String String
forall a. IO a -> a
unsafePerformIO (IO (Either String String) -> Either String String)
-> (Value -> IO (Either String String))
-> Value
-> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (RepM String -> RepOptions -> IO (Either String String))
-> RepOptions -> RepM String -> IO (Either String String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip RepM String -> RepOptions -> IO (Either String String)
forall a. RepM a -> RepOptions -> IO (Either String a)
runRepM (Natural -> Bool -> Bool -> RepOptions
RepOptions Natural
100 Bool
True Bool
False) (RepM String -> IO (Either String String))
-> (Value -> RepM String) -> Value -> IO (Either String String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Box Value -> RepM String
prettyRep (Either Box Value -> RepM String)
-> (Value -> Either Box Value) -> Value -> RepM String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Either Box Value
forall a b. b -> Either a b
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 Value r -> a -> RepM r
valueFromData FromValue{info
r -> info
Char -> info
Double -> info
Double -> String -> info
Float -> info
Int -> info
Int64 -> info
Integer -> String -> info
[r] -> info
[r] -> Maybe Value -> info
[Either Value Char] -> Maybe Value -> info
Word -> info
Word -> [Word] -> info
Word64 -> info
Value -> info -> r
Name -> [Word] -> [r] -> info
Name -> [(String, r)] -> info
depthLimit :: info
other :: info
double# :: Double -> info
float# :: Float -> info
addr# :: Int -> info
word64# :: Word64 -> info
int64# :: Int64 -> info
word# :: Word -> info
int# :: Int -> info
floating :: Double -> String -> info
integral :: Integer -> String -> info
stmQueue :: info
mutVar :: r -> info
mVar :: info
mutByteArray :: info
byteArray :: Word -> [Word] -> info
bytecode :: info
thunk :: info
fun :: info
rec :: Name -> [(String, r)] -> info
con :: Name -> [Word] -> [r] -> info
tuple :: [r] -> info
char :: Char -> info
string :: [Either Value Char] -> Maybe Value -> info
list :: [r] -> Maybe Value -> info
box :: Value -> info -> r
depthLimit :: ()
other :: ()
double# :: ()
float# :: ()
addr# :: ()
word64# :: ()
int64# :: ()
word# :: ()
int# :: ()
floating :: ()
integral :: ()
stmQueue :: ()
mutVar :: ()
mVar :: ()
mutByteArray :: ()
byteArray :: ()
bytecode :: ()
thunk :: ()
fun :: ()
rec :: ()
con :: ()
tuple :: ()
char :: ()
string :: ()
list :: ()
box :: ()
..} a
a = (Natural -> a -> RepM r) -> a -> Natural -> RepM r
forall a b c. (a -> b -> c) -> b -> a -> c
flip Natural -> a -> RepM r
forall x. Data x => Natural -> x -> RepM r
go a
a (Natural -> RepM r) -> RepM Natural -> RepM r
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RepOptions -> Natural) -> RepM Natural
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RepOptions -> Natural
repDepth where
  go :: forall x. Data x => Natural -> x -> RepM r
  go :: Natural -> x -> RepM r
go Natural
n = (info -> r) -> RepM info -> RepM r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((info -> r) -> RepM info -> RepM r)
-> (x -> info -> r) -> x -> RepM info -> RepM r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> info -> r
box (Value -> info -> r) -> (x -> Value) -> x -> info -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Value
forall a. Data a => a -> Value
Value (x -> RepM info -> RepM r) -> (x -> RepM info) -> x -> RepM r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case Natural
n of
    Natural
0 -> \x
_ -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure info
depthLimit
    Natural
_ -> (x -> RepM info) -> (x -> RepM info) -> x -> RepM info
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked (\x
_ -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure info
thunk) \x
x -> case Constr -> ConstrRep
constrRep (Constr -> ConstrRep) -> Constr -> ConstrRep
forall a b. (a -> b) -> a -> b
$ x -> Constr
forall a. Data a => a -> Constr
toConstr x
x of
      IntConstr   Integer
i -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> info -> RepM info
forall a b. (a -> b) -> a -> b
$ Integer -> String -> info
integral Integer
i (String -> info) -> String -> info
forall a b. (a -> b) -> a -> b
$ Typeable x => String
forall a. Typeable a => String
prettyType @x
      FloatConstr Rational
r -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> info -> RepM info
forall a b. (a -> b) -> a -> b
$
        Double -> String -> info
floating
          case Typeable x => TypeRep x
forall k (a :: k). Typeable a => TypeRep a
typeRep @x of
            TypeRep x
Float  -> Float -> Double
float2Double x
Float
x
            TypeRep x
Double -> x
Double
x
            TypeRep x
_      -> Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r
          (Typeable x => String
forall a. Typeable a => String
prettyType @x)
      CharConstr  Char
c -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> info -> RepM info
forall a b. (a -> b) -> a -> b
$ Char -> info
char Char
c
      AlgConstr{}   -> case x -> TypeRep x
forall a. Typeable a => a -> TypeRep a
typeOf x
x of
        TypeRep x
String -> ([Either Value Char] -> Maybe Value -> info)
-> ([Either Value Char], Maybe Value) -> info
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Either Value Char] -> Maybe Value -> info
string (([Either Value Char], Maybe Value) -> info)
-> RepM ([Either Value Char], Maybe Value) -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> String -> RepM ([Either Value Char], Maybe Value)
stringRep Natural
n x
String
x
        TypeRep x
List   -> ([r] -> Maybe Value -> info) -> ([r], Maybe Value) -> info
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [r] -> Maybe Value -> info
list   (([r], Maybe Value) -> info)
-> RepM ([r], Maybe Value) -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [b] -> RepM ([r], Maybe Value)
forall x. Data [x] => Natural -> [x] -> RepM ([r], Maybe Value)
listRep   Natural
n x
[b]
x
        TypeRep x
_ -> x -> [r] -> info
forall x. Data x => x -> [r] -> info
conOf x
x ([r] -> info) -> ([r] -> [r]) -> [r] -> info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [r] -> [r]
forall a. [a] -> [a]
reverse ([r] -> info) -> RepM [r] -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          (forall b. Data b => RepM [r] -> b -> RepM [r])
-> RepM [r] -> x -> RepM [r]
forall a r.
Data a =>
(forall b. Data b => r -> b -> r) -> r -> a -> r
confoldl (\RepM [r]
ys b
y -> (:) (r -> [r] -> [r]) -> RepM r -> RepM ([r] -> [r])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> b -> RepM r
forall x. Data x => Natural -> x -> RepM r
go (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) b
y RepM ([r] -> [r]) -> RepM [r] -> RepM [r]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RepM [r]
ys) ([r] -> RepM [r]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) x
x

  conOf :: forall x. Data x => x -> [r] -> _
  conOf :: x -> [r] -> info
conOf x
x
    | Char
'(':String
_ <- Name -> String
nameId Name
c                     = [r] -> info
tuple
    | fs :: [String]
fs@(String
_:[String]
_) <- Constr -> [String]
constrFields (Constr -> [String]) -> Constr -> [String]
forall a b. (a -> b) -> a -> b
$ x -> Constr
forall a. Data a => a -> Constr
toConstr x
x = Name -> [(String, r)] -> info
rec Name
c ([(String, r)] -> info) -> ([r] -> [(String, r)]) -> [r] -> info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [r] -> [(String, r)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
fs
    | Bool
otherwise                             = Name -> [Word] -> [r] -> info
con Name
c []
    where c :: Name
c = x -> Name
forall a. Data a => a -> Name
conName x
x

  stringRep :: Natural -> String -> RepM ([Either Value Char], Maybe Value)
  stringRep :: Natural -> String -> RepM ([Either Value Char], Maybe Value)
stringRep Natural
0 = String -> RepM ([Either Value Char], Maybe Value)
forall x y. Data x => x -> RepM ([y], Maybe Value)
tailThunk
  stringRep Natural
n = (String -> RepM ([Either Value Char], Maybe Value))
-> (String -> RepM ([Either Value Char], Maybe Value))
-> String
-> RepM ([Either Value Char], Maybe Value)
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked String -> RepM ([Either Value Char], Maybe Value)
forall x y. Data x => x -> RepM ([y], Maybe Value)
tailThunk \case
    []   -> ([Either Value Char], Maybe Value)
-> RepM ([Either Value Char], Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe Value
forall a. Maybe a
Nothing)
    Char
c:String
cs -> ([Either Value Char] -> [Either Value Char])
-> ([Either Value Char], Maybe Value)
-> ([Either Value Char], Maybe Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (([Either Value Char] -> [Either Value Char])
 -> ([Either Value Char], Maybe Value)
 -> ([Either Value Char], Maybe Value))
-> (Either Value Char
    -> [Either Value Char] -> [Either Value Char])
-> Either Value Char
-> ([Either Value Char], Maybe Value)
-> ([Either Value Char], Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) (Either Value Char
 -> ([Either Value Char], Maybe Value)
 -> ([Either Value Char], Maybe Value))
-> RepM (Either Value Char)
-> RepM
     (([Either Value Char], Maybe Value)
      -> ([Either Value Char], Maybe Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Either Value Char)
-> (Char -> Either Value Char) -> Char -> RepM (Either Value Char)
forall a b. (a -> b) -> (a -> b) -> a -> RepM b
thunked' (Value -> Either Value Char
forall a b. a -> Either a b
Left (Value -> Either Value Char)
-> (Char -> Value) -> Char -> Either Value Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Value
forall a. Data a => a -> Value
Value) Char -> Either Value Char
forall a b. b -> Either a b
Right Char
c
                        RepM
  (([Either Value Char], Maybe Value)
   -> ([Either Value Char], Maybe Value))
-> RepM ([Either Value Char], Maybe Value)
-> RepM ([Either Value Char], Maybe Value)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> String -> RepM ([Either Value Char], Maybe Value)
stringRep (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) String
cs

  listRep :: forall x. Data [x] => Natural -> [x] -> RepM ([r], Maybe Value)
  listRep :: Natural -> [x] -> RepM ([r], Maybe Value)
listRep Natural
0 = [x] -> RepM ([r], Maybe Value)
forall x y. Data x => x -> RepM ([y], Maybe Value)
tailThunk
  listRep Natural
n = ([x] -> RepM ([r], Maybe Value))
-> ([x] -> RepM ([r], Maybe Value))
-> [x]
-> RepM ([r], Maybe Value)
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked [x] -> RepM ([r], Maybe Value)
forall x y. Data x => x -> RepM ([y], Maybe Value)
tailThunk \case
    []   -> ([r], Maybe Value) -> RepM ([r], Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe Value
forall a. Maybe a
Nothing)
    x
x:[x]
xs -> do
      -- We don't have 'Data a', so instead we capture first field of (':')
      -- with it's instance and ignore the rest
      r
x' <- Maybe (RepM r) -> RepM r
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (RepM r) -> RepM r) -> Maybe (RepM r) -> RepM r
forall a b. (a -> b) -> a -> b
$
        (forall b. Data b => Maybe (RepM r) -> b -> Maybe (RepM r))
-> Maybe (RepM r) -> [x] -> Maybe (RepM r)
forall a r.
Data a =>
(forall b. Data b => r -> b -> r) -> r -> a -> r
confoldl (\Maybe (RepM r)
r b
y -> Maybe (RepM r)
r Maybe (RepM r) -> Maybe (RepM r) -> Maybe (RepM r)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RepM r -> Maybe (RepM r)
forall a. a -> Maybe a
Just (Natural -> b -> RepM r
forall x. Data x => Natural -> x -> RepM r
go Natural
n b
y)) Maybe (RepM r)
forall a. Maybe a
Nothing [x
x]
      ([r] -> [r]) -> ([r], Maybe Value) -> ([r], Maybe Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (r
x'r -> [r] -> [r]
forall a. a -> [a] -> [a]
:) (([r], Maybe Value) -> ([r], Maybe Value))
-> RepM ([r], Maybe Value) -> RepM ([r], Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [x] -> RepM ([r], Maybe Value)
forall x. Data [x] => Natural -> [x] -> RepM ([r], Maybe Value)
listRep (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) [x]
xs

  tailThunk :: forall x y. Data x => x -> RepM ([y], Maybe Value)
  tailThunk :: x -> RepM ([y], Maybe Value)
tailThunk = ([y], Maybe Value) -> RepM ([y], Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([y], Maybe Value) -> RepM ([y], Maybe Value))
-> (x -> ([y], Maybe Value)) -> x -> RepM ([y], Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([],) (Maybe Value -> ([y], Maybe Value))
-> (x -> Maybe Value) -> x -> ([y], Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> (x -> Value) -> x -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Value
forall a. Data a => a -> Value
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 Box r -> a -> RepM r
boxFromAny FromValue{info
r -> info
Char -> info
Double -> info
Double -> String -> info
Float -> info
Int -> info
Int64 -> info
Integer -> String -> info
[r] -> info
[r] -> Maybe Box -> info
[Either Box Char] -> Maybe Box -> info
Word -> info
Word -> [Word] -> info
Word64 -> info
Box -> info -> r
Name -> [Word] -> [r] -> info
Name -> [(String, r)] -> info
depthLimit :: info
other :: info
double# :: Double -> info
float# :: Float -> info
addr# :: Int -> info
word64# :: Word64 -> info
int64# :: Int64 -> info
word# :: Word -> info
int# :: Int -> info
floating :: Double -> String -> info
integral :: Integer -> String -> info
stmQueue :: info
mutVar :: r -> info
mVar :: info
mutByteArray :: info
byteArray :: Word -> [Word] -> info
bytecode :: info
thunk :: info
fun :: info
rec :: Name -> [(String, r)] -> info
con :: Name -> [Word] -> [r] -> info
tuple :: [r] -> info
char :: Char -> info
string :: [Either Box Char] -> Maybe Box -> info
list :: [r] -> Maybe Box -> info
box :: Box -> info -> r
depthLimit :: ()
other :: ()
double# :: ()
float# :: ()
addr# :: ()
word64# :: ()
int64# :: ()
word# :: ()
int# :: ()
floating :: ()
integral :: ()
stmQueue :: ()
mutVar :: ()
mVar :: ()
mutByteArray :: ()
byteArray :: ()
bytecode :: ()
thunk :: ()
fun :: ()
rec :: ()
con :: ()
tuple :: ()
char :: ()
string :: ()
list :: ()
box :: ()
..} a
a = (Natural -> a -> RepM r) -> a -> Natural -> RepM r
forall a b c. (a -> b -> c) -> b -> a -> c
flip Natural -> a -> RepM r
forall x. Natural -> x -> RepM r
go a
a (Natural -> RepM r) -> RepM Natural -> RepM r
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (RepOptions -> Natural) -> RepM Natural
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RepOptions -> Natural
repDepth where
  go :: forall x. Natural -> x -> RepM r
  go :: Natural -> x -> RepM r
go = \case
    Natural
0 -> info -> x -> RepM r
forall x. info -> x -> RepM r
boxWith info
depthLimit
    Natural
d -> (x -> RepM r) -> (x -> RepM r) -> x -> RepM r
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked (info -> x -> RepM r
forall x. info -> x -> RepM r
boxWith info
thunk) \x
x ->
      IO Closure -> RepM Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (x -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
getClosureData x
x) RepM Closure -> (Closure -> RepM r) -> RepM r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ConstrClosure{ [Box]
ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs :: [Box]
ptrArgs, [Word]
dataArgs :: forall b. GenClosure b -> [Word]
dataArgs :: [Word]
dataArgs, String
pkg :: forall b. GenClosure b -> String
pkg :: String
pkg, String
modl :: forall b. GenClosure b -> String
modl :: String
modl, String
name :: forall b. GenClosure b -> String
name :: String
name } ->
          Box -> info -> r
box (x -> Box
forall a. a -> Box
asBox x
x) (info -> r) -> RepM info -> RepM r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case (String
pkg, String
modl, String
name) of
            (String
"ghc-prim", String
"GHC.Types", String
n)
              | String
"I#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Int x
x String
"Int"
              | String
"W#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Word x
x String
"Word"
              | String
"F#" <- String
n -> (Float -> Double) -> x -> String -> RepM info
forall y x. (x -> Double) -> y -> String -> RepM info
unsafeFloating Float -> Double
float2Double x
x String
"Float"
              | String
"D#" <- String
n -> (Double -> Double) -> x -> String -> RepM info
forall y x. (x -> Double) -> y -> String -> RepM info
unsafeFloating Double -> Double
forall a. a -> a
id x
x String
"Double"
              | String
"C#" <- String
n -> info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> info -> RepM info
forall a b. (a -> b) -> a -> b
$ Char -> info
char (x -> Char
unsafeCoerce# x
x :: Char)
              | String
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
":", String
"[]"] -> Natural -> [Box] -> RepM info
boxListRep Natural
d [Box]
ptrArgs
            -- TODO: integer-simple
            (String
"ghc-prim", String
"GHC.Tuple", String
_) ->
              [r] -> info
tuple ([r] -> info) -> RepM [r] -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Box] -> (Box -> RepM r) -> RepM [r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Box]
ptrArgs \(Box Any
y) -> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go (Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Any
y
            (String
"integer-wired-in", String
"GHC.Integer.Type", String
n)
              | String
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"S#", String
"Jp#", String
"Jn#"] ->
                x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Integer x
x String
"Integer"
            (String
"base", String
"GHC.Natural", String
n)
              | String
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"NatS#", String
"NatJ#"] ->
                x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Natural x
x String
"Natural"
            (String
"base", String
"GHC.Int", String
n)
              | String
"I8#"  <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Int8 x
x String
"Int8"
              | String
"I16#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Int16 x
x String
"Int16"
              | String
"I32#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Int32 x
x String
"Int32"
              | String
"I64#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Int64 x
x String
"Int64"
            (String
"base", String
"GHC.Word", String
n)
              | String
"W8#"  <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Word8 x
x String
"Word8"
              | String
"W16#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Word16 x
x String
"Word16"
              | String
"W32#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Word32 x
x String
"Word32"
              | String
"W64#" <- String
n -> x -> String -> RepM info
forall x b. Integral x => b -> String -> RepM info
unsafeIntegral @Word64 x
x String
"Word64"
            (String
_, String
_, String
n)
              | let fixity :: Fixity
fixity  = case String
n of Char
':':String
_ -> Fixity
Infix; String
_ -> Fixity
Prefix
                    boxName :: Name
boxName = String -> String -> String -> Fixity -> Name
Name String
pkg String
modl String
name Fixity
fixity ->
                Name -> [Word] -> [r] -> info
con Name
boxName [Word]
dataArgs ([r] -> info) -> RepM [r] -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Box] -> (Box -> RepM r) -> RepM [r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Box]
ptrArgs \(Box Any
y) -> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go (Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Any
y
        IndClosure StgInfoTable
_ (Box Any
i) -> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go (Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Any
i
        WeakClosure{ value :: forall b. GenClosure b -> b
value = Box Any
i } -> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go (Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Any
i
        MutVarClosure StgInfoTable
_ (Box Any
i) -> Box -> info -> r
box (x -> Box
forall a. a -> Box
asBox x
x) (info -> r) -> (r -> info) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> info
mutVar (r -> r) -> RepM r -> RepM r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go (Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) Any
i
        Closure
v -> r -> RepM r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> RepM r) -> r -> RepM r
forall a b. (a -> b) -> a -> b
$ Box -> info -> r
box (x -> Box
forall a. a -> Box
asBox x
x) case Closure
v of
          FunClosure{}           -> info
fun
          PAPClosure{}           -> info
fun
          BCOClosure{}           -> info
bytecode
          ArrWordsClosure StgInfoTable
_ Word
s [Word]
ws -> Word -> [Word] -> info
byteArray Word
s [Word]
ws
          MutArrClosure{}        -> info
mutByteArray
          MVarClosure{}          -> info
mVar
          BlockingQueueClosure{} -> info
stmQueue
          IntClosure PrimType
_ Int
i         -> Int -> info
int# Int
i
          WordClosure PrimType
_ Word
w        -> Word -> info
word# Word
w
          Int64Closure PrimType
_ Int64
i       -> Int64 -> info
int64# Int64
i
          Word64Closure PrimType
_ Word64
w      -> Word64 -> info
word64# Word64
w
          AddrClosure PrimType
_ Int
p        -> Int -> info
addr# Int
p
          FloatClosure PrimType
_ Float
f       -> Float -> info
float# Float
f
          DoubleClosure PrimType
_ Double
f      -> Double -> info
double# Double
f
          Closure
_ -> info
other

  boxWith :: forall x. _ -> x -> RepM r
  boxWith :: info -> x -> RepM r
boxWith info
r x
b = r -> RepM r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> RepM r) -> r -> RepM r
forall a b. (a -> b) -> a -> b
$ Box -> info -> r
box (x -> Box
forall a. a -> Box
asBox x
b) info
r

  unsafeIntegral :: forall x b. Integral x => b -> PrettyType -> RepM _
  unsafeIntegral :: b -> String -> RepM info
unsafeIntegral b
i = info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> (String -> info) -> String -> RepM info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String -> info
integral (x -> Integer
forall a. Integral a => a -> Integer
toInteger (b -> x
unsafeCoerce# b
i :: x))

  unsafeFloating :: forall y x. (x -> Double) -> y -> PrettyType -> RepM _
  unsafeFloating :: (x -> Double) -> y -> String -> RepM info
unsafeFloating x -> Double
f y
d = info -> RepM info
forall (f :: * -> *) a. Applicative f => a -> f a
pure (info -> RepM info) -> (String -> info) -> String -> RepM info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String -> info
floating (x -> Double
f (y -> x
unsafeCoerce# @_ @_ @y @x y
d))

  boxListRep :: Natural -> [Box] -> RepM _
  boxListRep :: Natural -> [Box] -> RepM info
boxListRep Natural
d = Natural -> Bool -> ([Box] -> [Box]) -> [Box] -> RepM info
goList Natural
d Bool
False [Box] -> [Box]
forall a. a -> a
id where
    goList :: Natural -> Bool -> ([Box] -> [Box]) -> [Box] -> RepM info
goList Natural
_ Bool
isStr [Box] -> [Box]
acc [] =
      Bool -> [Box] -> Maybe Box -> RepM info
mkList Bool
isStr ([Box] -> [Box]
acc []) Maybe Box
forall a. Maybe a
Nothing

    goList Natural
0 Bool
isStr [Box] -> [Box]
acc [Box
x, Box
xs] = Bool -> [Box] -> Maybe Box -> RepM info
mkList Bool
isStr ([Box] -> [Box]
acc [Box
x]) (Maybe Box -> RepM info) -> Maybe Box -> RepM info
forall a b. (a -> b) -> a -> b
$ Box -> Maybe Box
forall a. a -> Maybe a
Just Box
xs

    goList Natural
n Bool
isStr [Box] -> [Box]
acc [Box Any
x, Box Any
xs] = do
      Bool
isChar <- (Any -> RepM Bool) -> (Any -> RepM Bool) -> Any -> RepM Bool
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked (\Any
_ -> Bool -> RepM Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
        do IO Closure -> RepM Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Closure -> RepM Closure)
-> (Any -> IO Closure) -> Any -> RepM Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
getClosureData (Any -> RepM Closure)
-> (RepM Closure -> RepM Bool) -> Any -> RepM Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Closure -> Bool) -> RepM Closure -> RepM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
             Closure
CharClosure -> Bool
True
             Closure
_           -> Bool
False
        Any
x
      (Any -> RepM info) -> (Any -> RepM info) -> Any -> RepM info
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked
        do Bool -> [Box] -> Maybe Box -> RepM info
mkList (Bool
isStr Bool -> Bool -> Bool
|| Bool
isChar) ([Box] -> [Box]
acc [Any -> Box
forall a. a -> Box
asBox Any
x]) (Maybe Box -> RepM info) -> (Any -> Maybe Box) -> Any -> RepM info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Box -> Maybe Box
forall a. a -> Maybe a
Just (Box -> Maybe Box) -> (Any -> Box) -> Any -> Maybe Box
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Box
forall a. a -> Box
asBox
        do IO Closure -> RepM Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Closure -> RepM Closure)
-> (Any -> IO Closure) -> Any -> RepM Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
getClosureData (Any -> RepM Closure) -> (Closure -> RepM info) -> Any -> RepM info
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
             ConstrClosure{ [Box]
ptrArgs :: [Box]
ptrArgs :: forall b. GenClosure b -> [b]
ptrArgs } ->
               Natural -> Bool -> ([Box] -> [Box]) -> [Box] -> RepM info
goList (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1) (Bool
isStr Bool -> Bool -> Bool
|| Bool
isChar) ([Box] -> [Box]
acc ([Box] -> [Box]) -> ([Box] -> [Box]) -> [Box] -> [Box]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Any -> Box
forall a. a -> Box
asBox Any
x Box -> [Box] -> [Box]
forall a. a -> [a] -> [a]
:)) [Box]
ptrArgs
             Closure
_ -> RepM info
forall z. HasCallStack => z
invalidList
        Any
xs

    goList Natural
_ Bool
_ [Box] -> [Box]
_ [Box]
_ = RepM info
forall z. HasCallStack => z
invalidList

    invalidList :: HasCallStack => z
    invalidList :: z
invalidList = (HasCallStack => z) -> z
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => z) -> z) -> (HasCallStack => z) -> z
forall a b. (a -> b) -> a -> b
$
      String -> z
forall a. HasCallStack => String -> a
error String
"Heap.Console.Inspector.boxListRep: invalid list"

    mkList :: Bool -> [Box] -> Maybe Box -> RepM info
mkList Bool
False [Box]
xs Maybe Box
t = ([r] -> Maybe Box -> info) -> Maybe Box -> [r] -> info
forall a b c. (a -> b -> c) -> b -> a -> c
flip [r] -> Maybe Box -> info
list Maybe Box
t ([r] -> info) -> RepM [r] -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      [(Natural, Box)] -> ((Natural, Box) -> RepM r) -> RepM [r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Natural] -> [Box] -> [(Natural, Box)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
d, Natural
d Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1 .. Natural
0] [Box]
xs) \(Natural
n, Box Any
x) -> Natural -> Any -> RepM r
forall x. Natural -> x -> RepM r
go Natural
n Any
x
    mkList Bool
True  [Box]
xs Maybe Box
t = ([Either Box Char] -> Maybe Box -> info)
-> Maybe Box -> [Either Box Char] -> info
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Either Box Char] -> Maybe Box -> info
string Maybe Box
t ([Either Box Char] -> info) -> RepM [Either Box Char] -> RepM info
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Box] -> (Box -> RepM (Either Box Char)) -> RepM [Either Box Char]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Box]
xs \(Box Any
c) ->
      (Any -> Either Box Char)
-> (Any -> Either Box Char) -> Any -> RepM (Either Box Char)
forall a b. (a -> b) -> (a -> b) -> a -> RepM b
thunked' (Box -> Either Box Char
forall a b. a -> Either a b
Left (Box -> Either Box Char) -> (Any -> Box) -> Any -> Either Box Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Box
Box) (Char -> Either Box Char
forall a b. b -> Either a b
Right (Char -> Either Box Char)
-> (Any -> Char) -> Any -> Either Box Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
forall a. a -> a
id @Char (Char -> Char) -> (Any -> Char) -> Any -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Char
unsafeCoerce#) Any
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 :: Either Box Value -> Bool -> [String] -> RepM (Either Box Value)
index Either Box Value
a Bool
strict [String]
fs' = (RepOptions -> RepOptions)
-> RepM (Either Box Value) -> RepM (Either Box Value)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\RepOptions
o -> RepOptions
o{ repStrict :: Bool
repStrict = Bool
strict Bool -> Bool -> Bool
|| RepOptions -> Bool
repStrict RepOptions
o } ) (RepM (Either Box Value) -> RepM (Either Box Value))
-> RepM (Either Box Value) -> RepM (Either Box Value)
forall a b. (a -> b) -> a -> b
$
  (Box -> RepM Box)
-> (Value -> RepM Value)
-> Either Box Value
-> RepM (Either Box Value)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse
    (\(Box Any
x)   -> (([String] -> RepM Box) -> [String] -> RepM Box
forall a b. (a -> b) -> a -> b
$ [String]
fs') (([String] -> RepM Box) -> RepM Box)
-> RepM ([String] -> RepM Box) -> RepM Box
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FromValue Box ([String] -> RepM Box)
-> Any -> RepM ([String] -> RepM Box)
forall r a. FromValue Box r -> a -> RepM r
boxFromAny    FromValue :: forall box rep info.
(box -> info -> rep)
-> ([rep] -> Maybe box -> info)
-> ([Either box Char] -> Maybe box -> info)
-> (Char -> info)
-> ([rep] -> info)
-> (Name -> [Word] -> [rep] -> info)
-> (Name -> [(String, rep)] -> info)
-> info
-> info
-> info
-> (Word -> [Word] -> info)
-> info
-> info
-> (rep -> info)
-> info
-> (Integer -> String -> info)
-> (Double -> String -> info)
-> (Int -> info)
-> (Word -> info)
-> (Int64 -> info)
-> (Word64 -> info)
-> (Int -> info)
-> (Float -> info)
-> (Double -> info)
-> info
-> info
-> FromValue box rep
FromValue{Char -> Box -> [String] -> RepM Box
Double -> String -> Box -> [String] -> RepM Box
Double -> Box -> [String] -> RepM Box
Float -> Box -> [String] -> RepM Box
Int -> Box -> [String] -> RepM Box
Int64 -> Box -> [String] -> RepM Box
Integer -> String -> Box -> [String] -> RepM Box
[Either Box Char] -> Maybe Box -> Box -> [String] -> RepM Box
[[String] -> RepM Box] -> Maybe Box -> Box -> [String] -> RepM Box
[[String] -> RepM Box] -> Box -> [String] -> RepM Box
Word -> [Word] -> Box -> [String] -> RepM Box
Word -> Box -> [String] -> RepM Box
Word64 -> Box -> [String] -> RepM Box
Box -> [String] -> RepM Box
Box -> (Box -> [String] -> RepM Box) -> [String] -> RepM Box
Name
-> [Word] -> [[String] -> RepM Box] -> Box -> [String] -> RepM Box
Name
-> [(String, [String] -> RepM Box)] -> Box -> [String] -> RepM Box
([String] -> RepM Box) -> Box -> [String] -> RepM Box
forall b. b -> [String] -> RepM b
forall b. [[String] -> RepM b] -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall p b. p -> b -> [String] -> RepM b
forall p b.
p -> [(String, [String] -> RepM b)] -> b -> [String] -> RepM b
forall a b. a -> (a -> b) -> b
forall p p b. p -> p -> b -> [String] -> RepM b
forall p p b.
p -> p -> [[String] -> RepM b] -> b -> [String] -> RepM b
forall t t p. (t -> t) -> p -> t -> t
depthLimit :: forall b. b -> [String] -> RepM b
other :: forall b. b -> [String] -> RepM b
double# :: forall p b. p -> b -> [String] -> RepM b
float# :: forall p b. p -> b -> [String] -> RepM b
addr# :: forall p b. p -> b -> [String] -> RepM b
word64# :: forall p b. p -> b -> [String] -> RepM b
int64# :: forall p b. p -> b -> [String] -> RepM b
word# :: forall p b. p -> b -> [String] -> RepM b
int# :: forall p b. p -> b -> [String] -> RepM b
floating :: forall p p b. p -> p -> b -> [String] -> RepM b
integral :: forall p p b. p -> p -> b -> [String] -> RepM b
stmQueue :: forall b. b -> [String] -> RepM b
mutVar :: forall t t p. (t -> t) -> p -> t -> t
mVar :: forall b. b -> [String] -> RepM b
mutByteArray :: forall b. b -> [String] -> RepM b
byteArray :: forall p p b. p -> p -> b -> [String] -> RepM b
bytecode :: forall b. b -> [String] -> RepM b
thunk :: forall b. b -> [String] -> RepM b
fun :: forall b. b -> [String] -> RepM b
rec :: forall p b.
p -> [(String, [String] -> RepM b)] -> b -> [String] -> RepM b
con :: forall p p b.
p -> p -> [[String] -> RepM b] -> b -> [String] -> RepM b
tuple :: forall b. [[String] -> RepM b] -> b -> [String] -> RepM b
char :: forall p b. p -> b -> [String] -> RepM b
string :: forall p p b. p -> p -> b -> [String] -> RepM b
list :: forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
box :: forall a b. a -> (a -> b) -> b
depthLimit :: Box -> [String] -> RepM Box
other :: Box -> [String] -> RepM Box
double# :: Double -> Box -> [String] -> RepM Box
float# :: Float -> Box -> [String] -> RepM Box
addr# :: Int -> Box -> [String] -> RepM Box
word64# :: Word64 -> Box -> [String] -> RepM Box
int64# :: Int64 -> Box -> [String] -> RepM Box
word# :: Word -> Box -> [String] -> RepM Box
int# :: Int -> Box -> [String] -> RepM Box
floating :: Double -> String -> Box -> [String] -> RepM Box
integral :: Integer -> String -> Box -> [String] -> RepM Box
stmQueue :: Box -> [String] -> RepM Box
mutVar :: ([String] -> RepM Box) -> Box -> [String] -> RepM Box
mVar :: Box -> [String] -> RepM Box
mutByteArray :: Box -> [String] -> RepM Box
byteArray :: Word -> [Word] -> Box -> [String] -> RepM Box
bytecode :: Box -> [String] -> RepM Box
thunk :: Box -> [String] -> RepM Box
fun :: Box -> [String] -> RepM Box
rec :: Name
-> [(String, [String] -> RepM Box)] -> Box -> [String] -> RepM Box
con :: Name
-> [Word] -> [[String] -> RepM Box] -> Box -> [String] -> RepM Box
tuple :: [[String] -> RepM Box] -> Box -> [String] -> RepM Box
char :: Char -> Box -> [String] -> RepM Box
string :: [Either Box Char] -> Maybe Box -> Box -> [String] -> RepM Box
list :: [[String] -> RepM Box] -> Maybe Box -> Box -> [String] -> RepM Box
box :: Box -> (Box -> [String] -> RepM Box) -> [String] -> RepM Box
..} Any
x)
    (\(Value a
v) -> (([String] -> RepM Value) -> [String] -> RepM Value
forall a b. (a -> b) -> a -> b
$ [String]
fs') (([String] -> RepM Value) -> RepM Value)
-> RepM ([String] -> RepM Value) -> RepM Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FromValue Value ([String] -> RepM Value)
-> a -> RepM ([String] -> RepM Value)
forall a r. Data a => FromValue Value r -> a -> RepM r
valueFromData FromValue :: forall box rep info.
(box -> info -> rep)
-> ([rep] -> Maybe box -> info)
-> ([Either box Char] -> Maybe box -> info)
-> (Char -> info)
-> ([rep] -> info)
-> (Name -> [Word] -> [rep] -> info)
-> (Name -> [(String, rep)] -> info)
-> info
-> info
-> info
-> (Word -> [Word] -> info)
-> info
-> info
-> (rep -> info)
-> info
-> (Integer -> String -> info)
-> (Double -> String -> info)
-> (Int -> info)
-> (Word -> info)
-> (Int64 -> info)
-> (Word64 -> info)
-> (Int -> info)
-> (Float -> info)
-> (Double -> info)
-> info
-> info
-> FromValue box rep
FromValue{Char -> Value -> [String] -> RepM Value
Double -> String -> Value -> [String] -> RepM Value
Double -> Value -> [String] -> RepM Value
Float -> Value -> [String] -> RepM Value
Int -> Value -> [String] -> RepM Value
Int64 -> Value -> [String] -> RepM Value
Integer -> String -> Value -> [String] -> RepM Value
[Either Value Char]
-> Maybe Value -> Value -> [String] -> RepM Value
[[String] -> RepM Value]
-> Maybe Value -> Value -> [String] -> RepM Value
[[String] -> RepM Value] -> Value -> [String] -> RepM Value
Word -> [Word] -> Value -> [String] -> RepM Value
Word -> Value -> [String] -> RepM Value
Word64 -> Value -> [String] -> RepM Value
Value -> [String] -> RepM Value
Value
-> (Value -> [String] -> RepM Value) -> [String] -> RepM Value
Name
-> [Word]
-> [[String] -> RepM Value]
-> Value
-> [String]
-> RepM Value
Name
-> [(String, [String] -> RepM Value)]
-> Value
-> [String]
-> RepM Value
([String] -> RepM Value) -> Value -> [String] -> RepM Value
forall b. b -> [String] -> RepM b
forall b. [[String] -> RepM b] -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall p b. p -> b -> [String] -> RepM b
forall p b.
p -> [(String, [String] -> RepM b)] -> b -> [String] -> RepM b
forall a b. a -> (a -> b) -> b
forall p p b. p -> p -> b -> [String] -> RepM b
forall p p b.
p -> p -> [[String] -> RepM b] -> b -> [String] -> RepM b
forall t t p. (t -> t) -> p -> t -> t
depthLimit :: forall b. b -> [String] -> RepM b
other :: forall b. b -> [String] -> RepM b
double# :: forall p b. p -> b -> [String] -> RepM b
float# :: forall p b. p -> b -> [String] -> RepM b
addr# :: forall p b. p -> b -> [String] -> RepM b
word64# :: forall p b. p -> b -> [String] -> RepM b
int64# :: forall p b. p -> b -> [String] -> RepM b
word# :: forall p b. p -> b -> [String] -> RepM b
int# :: forall p b. p -> b -> [String] -> RepM b
floating :: forall p p b. p -> p -> b -> [String] -> RepM b
integral :: forall p p b. p -> p -> b -> [String] -> RepM b
stmQueue :: forall b. b -> [String] -> RepM b
mutVar :: forall t t p. (t -> t) -> p -> t -> t
mVar :: forall b. b -> [String] -> RepM b
mutByteArray :: forall b. b -> [String] -> RepM b
byteArray :: forall p p b. p -> p -> b -> [String] -> RepM b
bytecode :: forall b. b -> [String] -> RepM b
thunk :: forall b. b -> [String] -> RepM b
fun :: forall b. b -> [String] -> RepM b
rec :: forall p b.
p -> [(String, [String] -> RepM b)] -> b -> [String] -> RepM b
con :: forall p p b.
p -> p -> [[String] -> RepM b] -> b -> [String] -> RepM b
tuple :: forall b. [[String] -> RepM b] -> b -> [String] -> RepM b
char :: forall p b. p -> b -> [String] -> RepM b
string :: forall p p b. p -> p -> b -> [String] -> RepM b
list :: forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
box :: forall a b. a -> (a -> b) -> b
depthLimit :: Value -> [String] -> RepM Value
other :: Value -> [String] -> RepM Value
double# :: Double -> Value -> [String] -> RepM Value
float# :: Float -> Value -> [String] -> RepM Value
addr# :: Int -> Value -> [String] -> RepM Value
word64# :: Word64 -> Value -> [String] -> RepM Value
int64# :: Int64 -> Value -> [String] -> RepM Value
word# :: Word -> Value -> [String] -> RepM Value
int# :: Int -> Value -> [String] -> RepM Value
floating :: Double -> String -> Value -> [String] -> RepM Value
integral :: Integer -> String -> Value -> [String] -> RepM Value
stmQueue :: Value -> [String] -> RepM Value
mutVar :: ([String] -> RepM Value) -> Value -> [String] -> RepM Value
mVar :: Value -> [String] -> RepM Value
mutByteArray :: Value -> [String] -> RepM Value
byteArray :: Word -> [Word] -> Value -> [String] -> RepM Value
bytecode :: Value -> [String] -> RepM Value
thunk :: Value -> [String] -> RepM Value
fun :: Value -> [String] -> RepM Value
rec :: Name
-> [(String, [String] -> RepM Value)]
-> Value
-> [String]
-> RepM Value
con :: Name
-> [Word]
-> [[String] -> RepM Value]
-> Value
-> [String]
-> RepM Value
tuple :: [[String] -> RepM Value] -> Value -> [String] -> RepM Value
char :: Char -> Value -> [String] -> RepM Value
string :: [Either Value Char]
-> Maybe Value -> Value -> [String] -> RepM Value
list :: [[String] -> RepM Value]
-> Maybe Value -> Value -> [String] -> RepM Value
box :: Value
-> (Value -> [String] -> RepM Value) -> [String] -> RepM Value
..} a
v)
    Either Box Value
a
 where
  withIndexes
    :: ([String] -> String -> RepM b) -> b -> [String] -> RepM b
  withIndexes :: ([String] -> String -> RepM b) -> b -> [String] -> RepM b
withIndexes [String] -> String -> RepM b
_ b
b []     = b -> RepM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
  withIndexes [String] -> String -> RepM b
g b
_ (String
f:[String]
fs) = [String] -> String -> RepM b
g [String]
fs String
f

  withList
    :: [[String] -> RepM b]
    -> Maybe b
    -> b -> [String] -> RepM b
  withList :: [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
withList [[String] -> RepM b]
xs Maybe b
t = ([String] -> String -> RepM b) -> b -> [String] -> RepM b
forall b. ([String] -> String -> RepM b) -> b -> [String] -> RepM b
withIndexes \[String]
fs -> \case
    String
s | Just Natural
i <- String -> Maybe Natural
forall a. Read a => String -> Maybe a
readMaybe @Natural String
s ->
        case (Int -> [[String] -> RepM b] -> [[String] -> RepM b]
forall a. Int -> [a] -> [a]
drop (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i) [[String] -> RepM b]
xs, Maybe b
t) of
          ([String] -> RepM b
x:[[String] -> RepM b]
_, Maybe b
_) -> [String] -> RepM b
x [String]
fs
          ([], Maybe b
Nothing) -> String -> RepM b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RepM b) -> String -> RepM b
forall a b. (a -> b) -> a -> b
$ String
"index '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' out of range"
          ([], Just{}) -> String -> RepM b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RepM b) -> String -> RepM b
forall a b. (a -> b) -> a -> b
$
            String
"index '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' not yet evaluated, try using '!'"
      | Bool
otherwise -> String -> RepM b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RepM b) -> String -> RepM b
forall a b. (a -> b) -> a -> b
$
        String
"expected positive integer as index, found '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"

  notIndexable :: String -> b -> [String] -> RepM b
  notIndexable :: String -> b -> [String] -> RepM b
notIndexable String
_   b
b [] = b -> RepM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
  notIndexable String
msg b
_ [String]
fs = String -> RepM b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RepM b) -> String -> RepM b
forall a b. (a -> b) -> a -> b
$
    String
"unexpected indexing '." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." [String]
fs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

  box :: a -> (a -> b) -> b
box = a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
(&)

  list :: [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
list = [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
withList

  -- TODO: make indexable
  string :: p -> p -> b -> [String] -> RepM b
string p
_ p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'String'"
  char :: p -> b -> [String] -> RepM b
char p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Char'"

  tuple :: [[String] -> RepM b] -> b -> [String] -> RepM b
tuple = ([[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b)
-> Maybe b -> [[String] -> RepM b] -> b -> [String] -> RepM b
forall a b c. (a -> b -> c) -> b -> a -> c
flip [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
withList Maybe b
forall a. Maybe a
Nothing

  con :: p -> p -> [[String] -> RepM b] -> b -> [String] -> RepM b
con p
_ p
_ = ([[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b)
-> Maybe b -> [[String] -> RepM b] -> b -> [String] -> RepM b
forall a b c. (a -> b -> c) -> b -> a -> c
flip [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
withList Maybe b
forall a. Maybe a
Nothing

  rec :: p -> [(String, [String] -> RepM b)] -> b -> [String] -> RepM b
rec p
_ [(String, [String] -> RepM b)]
xs b
b [String]
is =
    [[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
forall b.
[[String] -> RepM b] -> Maybe b -> b -> [String] -> RepM b
withList ((String, [String] -> RepM b) -> [String] -> RepM b
forall a b. (a, b) -> b
snd ((String, [String] -> RepM b) -> [String] -> RepM b)
-> [(String, [String] -> RepM b)] -> [[String] -> RepM b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, [String] -> RepM b)]
xs) Maybe b
forall a. Maybe a
Nothing b
b [String]
is RepM b -> (String -> RepM b) -> RepM b
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \String
_ ->
      ([String] -> String -> RepM b) -> b -> [String] -> RepM b
forall b. ([String] -> String -> RepM b) -> b -> [String] -> RepM b
withIndexes [String] -> String -> RepM b
goRec b
b [String]
is
   where
    goRec :: [String] -> String -> RepM b
goRec [String]
fs String
f = case String
-> [(String, [String] -> RepM b)] -> Maybe ([String] -> RepM b)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
f [(String, [String] -> RepM b)]
xs of
      Maybe ([String] -> RepM b)
Nothing -> String -> RepM b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> RepM b) -> String -> RepM b
forall a b. (a -> b) -> a -> b
$ String
"no index or field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' found"
      Just [String] -> RepM b
x  -> [String] -> RepM b
x [String]
fs

  fun :: b -> [String] -> RepM b
fun = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"a function"
  thunk :: b -> [String] -> RepM b
thunk = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"a thunk - try using '!'"
  bytecode :: b -> [String] -> RepM b
bytecode = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"bytecode"
  byteArray :: p -> p -> b -> [String] -> RepM b
byteArray p
_ p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'ByteArray#' - currently not supported"
  mutByteArray :: b -> [String] -> RepM b
mutByteArray = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'MutableByteArray#' - currently not supported"
  mVar :: b -> [String] -> RepM b
mVar = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'MVar#' - currently not supported"

  mutVar :: (t -> t) -> p -> t -> t
mutVar t -> t
r p
_ t
fs = t -> t
r t
fs

  stmQueue :: b -> [String] -> RepM b
stmQueue = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"a STM queue"
  integral :: p -> p -> b -> [String] -> RepM b
integral p
_ p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"an integral number"
  floating :: p -> p -> b -> [String] -> RepM b
floating p
_ p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"an floating number"
  int# :: p -> b -> [String] -> RepM b
int# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Int#'"
  word# :: p -> b -> [String] -> RepM b
word# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Word#'"
  int64# :: p -> b -> [String] -> RepM b
int64# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Int64#'"
  word64# :: p -> b -> [String] -> RepM b
word64# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Word64#'"
  addr# :: p -> b -> [String] -> RepM b
addr# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"an address"
  float# :: p -> b -> [String] -> RepM b
float# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Float#'"
  double# :: p -> b -> [String] -> RepM b
double# p
_ = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"'Double#'"
  other :: b -> [String] -> RepM b
other = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"an unknown value"
  depthLimit :: b -> [String] -> RepM b
depthLimit = String -> b -> [String] -> RepM b
forall b. String -> b -> [String] -> RepM b
notIndexable String
"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 :: Either Box Value -> RepM String
prettyRep Either Box Value
a = RepM RepOptions
forall r (m :: * -> *). MonadReader r m => m r
ask RepM RepOptions -> (RepOptions -> RepM String) -> RepM String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RepOptions -> RepM String
go where
  go :: RepOptions -> RepM String
go RepOptions{Bool
Natural
repTypes :: Bool
repStrict :: Bool
repDepth :: Natural
repTypes :: RepOptions -> Bool
repStrict :: RepOptions -> Bool
repDepth :: RepOptions -> Natural
..} = do
    Int -> ShowS
pretty <- case Either Box Value
a of
      Left (Box Any
x)    -> FromValue Box (Int -> ShowS) -> Any -> RepM (Int -> ShowS)
forall r a. FromValue Box r -> a -> RepM r
boxFromAny    FromValue :: forall box rep info.
(box -> info -> rep)
-> ([rep] -> Maybe box -> info)
-> ([Either box Char] -> Maybe box -> info)
-> (Char -> info)
-> ([rep] -> info)
-> (Name -> [Word] -> [rep] -> info)
-> (Name -> [(String, rep)] -> info)
-> info
-> info
-> info
-> (Word -> [Word] -> info)
-> info
-> info
-> (rep -> info)
-> info
-> (Integer -> String -> info)
-> (Double -> String -> info)
-> (Int -> info)
-> (Word -> info)
-> (Int64 -> info)
-> (Word64 -> info)
-> (Int -> info)
-> (Float -> info)
-> (Double -> info)
-> info
-> info
-> FromValue box rep
FromValue{Char -> Int -> ShowS
Double -> Int -> ShowS
Double -> String -> Int -> ShowS
Float -> Int -> ShowS
Int -> Int -> ShowS
Int -> ShowS
Int64 -> Int -> ShowS
Integer -> String -> Int -> ShowS
[Either Box Char] -> Maybe Box -> Int -> ShowS
[Int -> ShowS] -> Int -> ShowS
[Int -> ShowS] -> Maybe Box -> Int -> ShowS
Word -> Int -> ShowS
Word -> [Word] -> Int -> ShowS
Word64 -> Int -> ShowS
Box -> (Int -> ShowS) -> Int -> ShowS
Name -> [Word] -> [Int -> ShowS] -> Int -> ShowS
Name -> [(String, Int -> ShowS)] -> Int -> ShowS
(Int -> ShowS) -> Int -> ShowS
forall a. (Ord a, Num a) => a -> ShowS
forall a. Show a => Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
forall p a. p -> a -> a
forall a p. Num a => [a -> ShowS] -> p -> ShowS
forall a a p. Num a => [a -> ShowS] -> Maybe a -> p -> ShowS
forall b p p. Show b => p -> [b] -> p -> ShowS
forall (t :: * -> *) a a p.
(Foldable t, Functor t) =>
t (Either a Char) -> Maybe a -> p -> ShowS
depthLimit :: Int -> ShowS
other :: Int -> ShowS
double# :: Double -> Int -> ShowS
float# :: Float -> Int -> ShowS
addr# :: Int -> Int -> ShowS
word64# :: Word64 -> Int -> ShowS
int64# :: Int64 -> Int -> ShowS
word# :: Word -> Int -> ShowS
int# :: Int -> Int -> ShowS
floating :: Double -> String -> Int -> ShowS
integral :: Integer -> String -> Int -> ShowS
stmQueue :: Int -> ShowS
mutVar :: (Int -> ShowS) -> Int -> ShowS
mVar :: Int -> ShowS
mutByteArray :: Int -> ShowS
byteArray :: forall b p p. Show b => p -> [b] -> p -> ShowS
bytecode :: Int -> ShowS
thunk :: Int -> ShowS
fun :: forall a. (Ord a, Num a) => a -> ShowS
rec :: Name -> [(String, Int -> ShowS)] -> Int -> ShowS
con :: forall a. Show a => Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
tuple :: forall a p. Num a => [a -> ShowS] -> p -> ShowS
char :: Char -> Int -> ShowS
string :: forall (t :: * -> *) a a p.
(Foldable t, Functor t) =>
t (Either a Char) -> Maybe a -> p -> ShowS
list :: forall a a p. Num a => [a -> ShowS] -> Maybe a -> p -> ShowS
box :: forall p a. p -> a -> a
depthLimit :: Int -> ShowS
other :: Int -> ShowS
double# :: Double -> Int -> ShowS
float# :: Float -> Int -> ShowS
addr# :: Int -> Int -> ShowS
word64# :: Word64 -> Int -> ShowS
int64# :: Int64 -> Int -> ShowS
word# :: Word -> Int -> ShowS
int# :: Int -> Int -> ShowS
floating :: Double -> String -> Int -> ShowS
integral :: Integer -> String -> Int -> ShowS
stmQueue :: Int -> ShowS
mutVar :: (Int -> ShowS) -> Int -> ShowS
mVar :: Int -> ShowS
mutByteArray :: Int -> ShowS
byteArray :: Word -> [Word] -> Int -> ShowS
bytecode :: Int -> ShowS
thunk :: Int -> ShowS
fun :: Int -> ShowS
rec :: Name -> [(String, Int -> ShowS)] -> Int -> ShowS
con :: Name -> [Word] -> [Int -> ShowS] -> Int -> ShowS
tuple :: [Int -> ShowS] -> Int -> ShowS
char :: Char -> Int -> ShowS
string :: [Either Box Char] -> Maybe Box -> Int -> ShowS
list :: [Int -> ShowS] -> Maybe Box -> Int -> ShowS
box :: Box -> (Int -> ShowS) -> Int -> ShowS
..} Any
x
      Right (Value a
v) -> FromValue Value (Int -> ShowS) -> a -> RepM (Int -> ShowS)
forall a r. Data a => FromValue Value r -> a -> RepM r
valueFromData FromValue :: forall box rep info.
(box -> info -> rep)
-> ([rep] -> Maybe box -> info)
-> ([Either box Char] -> Maybe box -> info)
-> (Char -> info)
-> ([rep] -> info)
-> (Name -> [Word] -> [rep] -> info)
-> (Name -> [(String, rep)] -> info)
-> info
-> info
-> info
-> (Word -> [Word] -> info)
-> info
-> info
-> (rep -> info)
-> info
-> (Integer -> String -> info)
-> (Double -> String -> info)
-> (Int -> info)
-> (Word -> info)
-> (Int64 -> info)
-> (Word64 -> info)
-> (Int -> info)
-> (Float -> info)
-> (Double -> info)
-> info
-> info
-> FromValue box rep
FromValue{Char -> Int -> ShowS
Double -> Int -> ShowS
Double -> String -> Int -> ShowS
Float -> Int -> ShowS
Int -> Int -> ShowS
Int -> ShowS
Int64 -> Int -> ShowS
Integer -> String -> Int -> ShowS
[Either Value Char] -> Maybe Value -> Int -> ShowS
[Int -> ShowS] -> Int -> ShowS
[Int -> ShowS] -> Maybe Value -> Int -> ShowS
Word -> Int -> ShowS
Word -> [Word] -> Int -> ShowS
Word64 -> Int -> ShowS
Value -> (Int -> ShowS) -> Int -> ShowS
Name -> [Word] -> [Int -> ShowS] -> Int -> ShowS
Name -> [(String, Int -> ShowS)] -> Int -> ShowS
(Int -> ShowS) -> Int -> ShowS
forall a. (Ord a, Num a) => a -> ShowS
forall a. Show a => Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
forall p a. p -> a -> a
forall a p. Num a => [a -> ShowS] -> p -> ShowS
forall a a p. Num a => [a -> ShowS] -> Maybe a -> p -> ShowS
forall b p p. Show b => p -> [b] -> p -> ShowS
forall (t :: * -> *) a a p.
(Foldable t, Functor t) =>
t (Either a Char) -> Maybe a -> p -> ShowS
depthLimit :: Int -> ShowS
other :: Int -> ShowS
double# :: Double -> Int -> ShowS
float# :: Float -> Int -> ShowS
addr# :: Int -> Int -> ShowS
word64# :: Word64 -> Int -> ShowS
int64# :: Int64 -> Int -> ShowS
word# :: Word -> Int -> ShowS
int# :: Int -> Int -> ShowS
floating :: Double -> String -> Int -> ShowS
integral :: Integer -> String -> Int -> ShowS
stmQueue :: Int -> ShowS
mutVar :: (Int -> ShowS) -> Int -> ShowS
mVar :: Int -> ShowS
mutByteArray :: Int -> ShowS
byteArray :: forall b p p. Show b => p -> [b] -> p -> ShowS
bytecode :: Int -> ShowS
thunk :: Int -> ShowS
fun :: forall a. (Ord a, Num a) => a -> ShowS
rec :: Name -> [(String, Int -> ShowS)] -> Int -> ShowS
con :: forall a. Show a => Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
tuple :: forall a p. Num a => [a -> ShowS] -> p -> ShowS
char :: Char -> Int -> ShowS
string :: forall (t :: * -> *) a a p.
(Foldable t, Functor t) =>
t (Either a Char) -> Maybe a -> p -> ShowS
list :: forall a a p. Num a => [a -> ShowS] -> Maybe a -> p -> ShowS
box :: forall p a. p -> a -> a
depthLimit :: Int -> ShowS
other :: Int -> ShowS
double# :: Double -> Int -> ShowS
float# :: Float -> Int -> ShowS
addr# :: Int -> Int -> ShowS
word64# :: Word64 -> Int -> ShowS
int64# :: Int64 -> Int -> ShowS
word# :: Word -> Int -> ShowS
int# :: Int -> Int -> ShowS
floating :: Double -> String -> Int -> ShowS
integral :: Integer -> String -> Int -> ShowS
stmQueue :: Int -> ShowS
mutVar :: (Int -> ShowS) -> Int -> ShowS
mVar :: Int -> ShowS
mutByteArray :: Int -> ShowS
byteArray :: Word -> [Word] -> Int -> ShowS
bytecode :: Int -> ShowS
thunk :: Int -> ShowS
fun :: Int -> ShowS
rec :: Name -> [(String, Int -> ShowS)] -> Int -> ShowS
con :: Name -> [Word] -> [Int -> ShowS] -> Int -> ShowS
tuple :: [Int -> ShowS] -> Int -> ShowS
char :: Char -> Int -> ShowS
string :: [Either Value Char] -> Maybe Value -> Int -> ShowS
list :: [Int -> ShowS] -> Maybe Value -> Int -> ShowS
box :: Value -> (Int -> ShowS) -> Int -> ShowS
..} a
v
    String -> RepM String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> RepM String) -> String -> RepM String
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
pretty Int
-1 String
""
   where
    -- NOTE: 'dataToHsRep' does forcing, so don't bother with forcing of thunks
    -- during printing.

    signature :: Show b => b -> String -> PrecShowS
    signature :: b -> String -> Int -> ShowS
signature b
b String
t = if Bool
repTypes
      then String -> Int -> (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showInfix String
"::" Int
-1 (b -> Int -> ShowS
forall b. Show b => b -> Int -> ShowS
precShow b
b) \Int
_ -> (String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++)
      else b -> Int -> ShowS
forall b. Show b => b -> Int -> ShowS
precShow b
b

    postfix :: Show b => String -> b -> PrecShowS
    postfix :: String -> b -> Int -> ShowS
postfix String
p b
b Int
_ = b -> ShowS
forall a. Show a => a -> ShowS
shows b
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++)

    precShow :: Show b => b -> PrecShowS
    precShow :: b -> Int -> ShowS
precShow = (Int -> b -> ShowS) -> b -> Int -> ShowS
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> b -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

    intercalateS :: String -> [ShowS] -> ShowS
    intercalateS :: String -> [ShowS] -> ShowS
intercalateS String
_ []     = ShowS
forall a. a -> a
id
    intercalateS String
_ [ShowS
x]    = ShowS
x
    intercalateS String
s (ShowS
x:[ShowS]
xs) = ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ShowS] -> ShowS
intercalateS String
s [ShowS]
xs

    box :: p -> a -> a
box p
_ = a -> a
forall a. a -> a
id

    list :: [a -> ShowS] -> Maybe a -> p -> ShowS
list [a -> ShowS]
xs Maybe a
t p
_ = (Char
'['Char -> ShowS
forall a. a -> [a] -> [a]
:)
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ShowS] -> ShowS
intercalateS String
", " ([a -> ShowS]
xs [a -> ShowS] -> ((a -> ShowS) -> ShowS) -> [ShowS]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((a -> ShowS) -> a -> ShowS
forall a b. (a -> b) -> a -> b
$ a
-1))
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
(++) if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
t then String
", .." else String
"")
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:)

    string :: t (Either a Char) -> Maybe a -> p -> ShowS
string t (Either a Char)
cs Maybe a
t p
_ = (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:)
                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> t ShowS -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((a -> ShowS) -> (Char -> ShowS) -> Either a Char -> ShowS
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
_ -> (String
"\"_\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (:) (Either a Char -> ShowS) -> t (Either a Char) -> t ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Either a Char)
cs)
                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:)
                  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. [a] -> [a] -> [a]
(++) if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
t then String
".." else String
""

    char :: Char -> Int -> ShowS
char = Char -> Int -> ShowS
forall b. Show b => b -> Int -> ShowS
precShow

    tuple :: [a -> ShowS] -> p -> ShowS
tuple [a -> ShowS]
xs p
_ = (Char
'('Char -> ShowS
forall a. a -> [a] -> [a]
:)
               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ShowS] -> ShowS
intercalateS String
", " ([a -> ShowS]
xs [a -> ShowS] -> ((a -> ShowS) -> ShowS) -> [ShowS]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ((a -> ShowS) -> a -> ShowS
forall a b. (a -> b) -> a -> b
$ a
-1))
               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')'Char -> ShowS
forall a. a -> [a] -> [a]
:)

    con :: Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
con n :: Name
n@Name{String
Fixity
nameFixity :: Fixity
nameId :: String
nameMod :: String
namePkg :: String
nameFixity :: Name -> Fixity
nameId :: Name -> String
nameMod :: Name -> String
namePkg :: Name -> String
..} [a]
ws [Int -> ShowS]
xs = case Fixity
nameFixity of
      Fixity
Prefix -> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> (Int -> ShowS) -> [Int -> ShowS] -> Int -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp
        (((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> (Int -> ShowS) -> [Int -> ShowS] -> Int -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp (String -> Int -> ShowS
showCon String
nameId) ([Int -> ShowS] -> Int -> ShowS) -> [Int -> ShowS] -> Int -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> a -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"##" (a -> Int -> ShowS) -> [a] -> [Int -> ShowS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ws)
        [Int -> ShowS]
xs
      Fixity
Infix -> case (String -> a -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"##" (a -> Int -> ShowS) -> [a] -> [Int -> ShowS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ws) [Int -> ShowS] -> [Int -> ShowS] -> [Int -> ShowS]
forall a. [a] -> [a] -> [a]
++ [Int -> ShowS]
xs of
        []     -> ShowS -> Int -> ShowS
forall a b. a -> b -> a
const (Bool -> ShowS -> ShowS
showParen Bool
True (String
nameId String -> ShowS
forall a. [a] -> [a] -> [a]
++))
        [Int -> ShowS
x]    -> ShowS -> Int -> ShowS
forall a b. a -> b -> a
const (Bool -> ShowS -> ShowS
showParen Bool
True (String
nameId String -> ShowS
forall a. [a] -> [a] -> [a]
++)) (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
`showApp` Int -> ShowS
x
        [Int -> ShowS
x, Int -> ShowS
y] -> String -> Int -> (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showInfix String
nameId Int
9 Int -> ShowS
x Int -> ShowS
y
        Int -> ShowS
x:Int -> ShowS
y:[Int -> ShowS]
ys -> ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> (Int -> ShowS) -> [Int -> ShowS] -> Int -> ShowS
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp (Name -> [a] -> [Int -> ShowS] -> Int -> ShowS
con Name
n [] [Int -> ShowS
x, Int -> ShowS
y]) [Int -> ShowS]
ys

    rec :: Name -> [(String, Int -> ShowS)] -> Int -> ShowS
rec Name{String
Fixity
nameFixity :: Fixity
nameId :: String
nameMod :: String
namePkg :: String
nameFixity :: Name -> Fixity
nameId :: Name -> String
nameMod :: Name -> String
namePkg :: Name -> String
..} = String -> ShowS -> Int -> ShowS
showRecord String
n (ShowS -> Int -> ShowS)
-> ([(String, Int -> ShowS)] -> ShowS)
-> [(String, Int -> ShowS)]
-> Int
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      [] -> ShowS
noFields
      [(String, Int -> ShowS)]
xs -> (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall a. (a -> a -> a) -> [a] -> a
foldl1' ShowS -> ShowS -> ShowS
(&|) ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ (String -> (Int -> ShowS) -> ShowS)
-> (String, Int -> ShowS) -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> (Int -> ShowS) -> ShowS
showField ((String, Int -> ShowS) -> ShowS)
-> [(String, Int -> ShowS)] -> [ShowS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Int -> ShowS)]
xs
     where
      n :: String
n = case Fixity
nameFixity of
        Fixity
Infix  -> Char
'(' Char -> ShowS
forall a. a -> [a] -> [a]
: String
nameId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        Fixity
Prefix -> String
nameId

    fun :: a -> ShowS
fun a
p = Bool -> ShowS -> ShowS
showParen (a
p a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
-1) (String
"\\_ -> _" String -> ShowS
forall a. [a] -> [a] -> [a]
++)
    thunk :: Int -> ShowS
thunk = String -> Int -> ShowS
showCon String
"_"
    bytecode :: Int -> ShowS
bytecode = String -> Int -> ShowS
showCon String
"_bytecode"
    byteArray :: p -> [b] -> p -> ShowS
byteArray p
_ [b]
ws p
p = [Int -> ShowS] -> Maybe Any -> p -> ShowS
forall a a p. Num a => [a -> ShowS] -> Maybe a -> p -> ShowS
list (String -> b -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"#" (b -> Int -> ShowS) -> [b] -> [Int -> ShowS]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [b]
ws) Maybe Any
forall a. Maybe a
Nothing p
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'#'Char -> ShowS
forall a. a -> [a] -> [a]
:)
    mutByteArray :: Int -> ShowS
mutByteArray = String -> Int -> ShowS
showCon String
"_mutByteArray"
    mVar :: Int -> ShowS
mVar = String -> Int -> ShowS
showCon String
"_mVar"
    mutVar :: (Int -> ShowS) -> Int -> ShowS
mutVar = (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
showApp ((Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS)
-> (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> Int -> ShowS
showCon String
"MutVar#"
    stmQueue :: Int -> ShowS
stmQueue = String -> Int -> ShowS
showCon String
"_stmQueue"
    integral :: Integer -> String -> Int -> ShowS
integral = Integer -> String -> Int -> ShowS
forall b. Show b => b -> String -> Int -> ShowS
signature
    floating :: Double -> String -> Int -> ShowS
floating = Double -> String -> Int -> ShowS
forall b. Show b => b -> String -> Int -> ShowS
signature
    int# :: Int -> Int -> ShowS
int# = String -> Int -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"#"
    word# :: Word -> Int -> ShowS
word# = String -> Word -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"##"
    int64# :: Int64 -> Int -> ShowS
int64# = String -> Int64 -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"L#"
    word64# :: Word64 -> Int -> ShowS
word64# = String -> Word64 -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"L##"
    addr# :: Int -> Int -> ShowS
addr# (I# Int#
i) = String -> Int -> ShowS
forall b. Show b => b -> Int -> ShowS
precShow (String -> Int -> ShowS) -> String -> Int -> ShowS
forall a b. (a -> b) -> a -> b
$ Addr# -> String
unpackCString# (Int# -> Addr#
unsafeCoerce# Int#
i)
    float# :: Float -> Int -> ShowS
float# = String -> Float -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"#"
    double# :: Double -> Int -> ShowS
double# = String -> Double -> Int -> ShowS
forall b. Show b => String -> b -> Int -> ShowS
postfix String
"##"
    other :: Int -> ShowS
other = String -> Int -> ShowS
showCon String
"_unknown"
    depthLimit :: Int -> ShowS
depthLimit = String -> Int -> ShowS
showCon String
".."

-------------------------------------------------------------------------------
-- | 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 :: (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked a -> RepM b
tf a -> RepM b
ntf a
a = (RepOptions -> Bool) -> RepM Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RepOptions -> Bool
repStrict RepM Bool -> (Bool -> RepM b) -> RepM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> a -> RepM Bool
forall (m :: * -> *) a. MonadIO m => a -> m Bool
isThunk a
a RepM Bool -> (Bool -> RepM b) -> RepM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RepM b -> RepM b -> Bool -> RepM b
forall a. a -> a -> Bool -> a
bool (a -> RepM b
ntf a
a) (a -> RepM b
tf a
a)
  Bool
True  -> a
a a -> RepM b -> RepM b
forall p a. p -> a -> a
`seq'` a -> RepM b
ntf a
a

-- | Version of 'thunked' taking pure functions.
thunked' :: (a -> b) -> (a -> b) -> a -> RepM b
thunked' :: (a -> b) -> (a -> b) -> a -> RepM b
thunked' a -> b
tf a -> b
ntf = (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
forall a b. (a -> RepM b) -> (a -> RepM b) -> a -> RepM b
thunked (b -> RepM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> RepM b) -> (a -> b) -> a -> RepM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
tf) (b -> RepM b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> RepM b) -> (a -> b) -> a -> RepM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
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 :: a -> m Bool
isThunk = IO Closure -> m Closure
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Closure -> m Closure) -> (a -> IO Closure) -> a -> m Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO Closure
forall a. HasHeapRep a => a -> IO Closure
getClosureData (a -> m Closure) -> (m Closure -> m Bool) -> a -> m Bool
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Closure -> Bool) -> m Closure -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
  ThunkClosure{} -> Bool
True
  SelectorClosure{} -> Bool
True
  APClosure{} -> Bool
True
  APStackClosure{} -> Bool
True
  BlackholeClosure{} -> Bool
True
  Closure
_ -> Bool
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 -> b -> b
seq' a
a = () -> b -> b
seq (() -> b -> b) -> () -> b -> b
forall a b. (a -> b) -> a -> b
$ IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
evaluate a
a IO a -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ()
performGC IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO Bool -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (a -> IO Bool
forall (m :: * -> *) a. MonadIO m => a -> m Bool
isThunk a
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 :: (forall b. Data b => r -> b -> r) -> r -> a -> r
confoldl forall b. Data b => r -> b -> r
c r
n = Const r a -> r
forall a k (b :: k). Const a b -> a
getConst (Const r a -> r) -> (a -> Const r a) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d b. Data d => Const r (d -> b) -> d -> Const r b)
-> (forall g. g -> Const r g) -> a -> Const r a
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a
gfoldl
  do \(Const acc) -> r -> Const r b
forall k a (b :: k). a -> Const a b
Const (r -> Const r b) -> (d -> r) -> d -> Const r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> d -> r
forall b. Data b => r -> b -> r
c r
acc
  do \g
_ -> r -> Const r g
forall k a (b :: k). a -> Const a b
Const r
n

-------------------------------------------------------------------------------
-- | Repeatedly evaluates provided action until it yields 'False'.
whileM :: Monad m => m Bool -> m ()
whileM :: m Bool -> m ()
whileM m Bool
mb = m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (m Bool -> m ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM m Bool
mb) (Bool -> m ()) -> m Bool -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Bool
mb

-------------------------------------------------------------------------------
-- | Tests equality of @a@ to @b@ described by given 'TypeRep'.
isType :: forall a b. Typeable a => TypeRep b -> Maybe (a :~~: b)
isType :: TypeRep b -> Maybe (a :~~: b)
isType = TypeRep a -> TypeRep b -> Maybe (a :~~: b)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
forall k (a :: k). Typeable a => TypeRep a
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 :: TypeRep a -> Maybe (IsCon f a)
isCon = \case
  App TypeRep a
l TypeRep b
_ | Just a :~~: f
HRefl <- TypeRep a -> TypeRep f -> Maybe (a :~~: f)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep TypeRep a
l (TypeRep f -> Maybe (a :~~: f)) -> TypeRep f -> Maybe (a :~~: f)
forall a b. (a -> b) -> a -> b
$ Typeable f => TypeRep f
forall k (a :: k). Typeable a => TypeRep a
typeRep @f -> IsCon f a -> Maybe (IsCon f a)
forall a. a -> Maybe a
Just IsCon f a
forall (f :: * -> *) a b. (a ~ f b) => IsCon f a
IsCon
  TypeRep a
_ -> Maybe (IsCon f a)
forall a. Maybe a
Nothing

pattern Float :: () => a ~ Float => TypeRep a
pattern $mFloat :: forall r a. TypeRep a -> ((a ~ Float) => r) -> (Void# -> r) -> r
Float <- (isType @Float -> Just HRefl)

pattern Double :: () => a ~ Double => TypeRep a
pattern $mDouble :: forall r a. TypeRep a -> ((a ~ Double) => r) -> (Void# -> r) -> r
Double <- (isType @Double -> Just HRefl)

pattern String :: () => a ~ String => TypeRep a
pattern $mString :: forall r a. TypeRep a -> ((a ~ String) => r) -> (Void# -> r) -> r
String <- (isType @String -> Just HRefl)

pattern List :: () => a ~ [b] => TypeRep a
pattern $mList :: forall r a.
TypeRep a -> (forall b. (a ~ [b]) => r) -> (Void# -> r) -> r
List <- (isCon @[] -> Just IsCon)

-------------------------------------------------------------------------------
pattern CharClosure :: GenClosure a
pattern $mCharClosure :: forall r a. GenClosure a -> (Void# -> r) -> (Void# -> r) -> r
CharClosure <-
  ConstrClosure{ pkg = "ghc-prim", modl = "GHC.Types", name = "C#" }