{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module Debug.RecoverRTTI.Modules (
KnownPkg(..)
, KnownModule(..)
, IsKnownPkg(..)
, inKnownModule
, inKnownModuleNested
) where
import Control.Monad
import Data.List (isPrefixOf)
import Debug.RecoverRTTI.FlatClosure
data KnownPkg =
PkgGhcPrim
| PkgBase
| PkgByteString
| PkgText
| PkgIntegerWiredIn
| PkgGhcBignum
| PkgContainers
| PkgAeson
| PkgUnorderedContainers
| PkgVector
| PkgPrimitive
data family KnownModule (pkg :: KnownPkg)
data SPkg (pkg :: KnownPkg) where
SGhcPrim :: SPkg 'PkgGhcPrim
SBase :: SPkg 'PkgBase
SByteString :: SPkg 'PkgByteString
SText :: SPkg 'PkgText
SIntegerWiredIn :: SPkg 'PkgIntegerWiredIn
SGhcBignum :: SPkg 'PkgGhcBignum
SContainers :: SPkg 'PkgContainers
SAeson :: SPkg 'PkgAeson
SUnorderedContainers :: SPkg 'PkgUnorderedContainers
SVector :: SPkg 'PkgVector
SPrimitive :: SPkg 'PkgPrimitive
class IsKnownPkg pkg where
singPkg :: SPkg pkg
instance IsKnownPkg 'PkgGhcPrim where singPkg :: SPkg 'PkgGhcPrim
singPkg = SPkg 'PkgGhcPrim
SGhcPrim
instance IsKnownPkg 'PkgBase where singPkg :: SPkg 'PkgBase
singPkg = SPkg 'PkgBase
SBase
instance IsKnownPkg 'PkgByteString where singPkg :: SPkg 'PkgByteString
singPkg = SPkg 'PkgByteString
SByteString
instance IsKnownPkg 'PkgText where singPkg :: SPkg 'PkgText
singPkg = SPkg 'PkgText
SText
instance IsKnownPkg 'PkgIntegerWiredIn where singPkg :: SPkg 'PkgIntegerWiredIn
singPkg = SPkg 'PkgIntegerWiredIn
SIntegerWiredIn
instance IsKnownPkg 'PkgGhcBignum where singPkg :: SPkg 'PkgGhcBignum
singPkg = SPkg 'PkgGhcBignum
SGhcBignum
instance IsKnownPkg 'PkgContainers where singPkg :: SPkg 'PkgContainers
singPkg = SPkg 'PkgContainers
SContainers
instance IsKnownPkg 'PkgAeson where singPkg :: SPkg 'PkgAeson
singPkg = SPkg 'PkgAeson
SAeson
instance IsKnownPkg 'PkgUnorderedContainers where singPkg :: SPkg 'PkgUnorderedContainers
singPkg = SPkg 'PkgUnorderedContainers
SUnorderedContainers
instance IsKnownPkg 'PkgVector where singPkg :: SPkg 'PkgVector
singPkg = SPkg 'PkgVector
SVector
instance IsKnownPkg 'PkgPrimitive where singPkg :: SPkg 'PkgPrimitive
singPkg = SPkg 'PkgPrimitive
SPrimitive
data instance KnownModule 'PkgGhcPrim =
GhcTypes
| GhcTuple
data instance KnownModule 'PkgBase =
GhcInt
| GhcWord
| GhcSTRef
| GhcMVar
| GhcConcSync
| GhcMaybe
| GhcReal
| DataEither
data instance KnownModule 'PkgByteString =
DataByteStringInternal
| DataByteStringLazyInternal
| DataByteStringShortInternal
data instance KnownModule 'PkgText =
DataTextInternal
| DataTextInternalLazy
data instance KnownModule 'PkgIntegerWiredIn =
GhcIntegerType
data instance KnownModule 'PkgGhcBignum =
GhcNumInteger
data instance KnownModule 'PkgContainers =
DataSetInternal
| DataMapInternal
| DataIntSetInternal
| DataIntMapInternal
| DataSequenceInternal
| DataTree
data instance KnownModule 'PkgAeson =
DataAesonTypesInternal
data instance KnownModule 'PkgUnorderedContainers =
DataHashMapInternal
| DataHashMapInternalArray
data instance KnownModule 'PkgVector =
DataVector
| DataVectorStorable
| DataVectorStorableMutable
| DataVectorPrimitive
| DataVectorPrimitiveMutable
data instance KnownModule 'PkgPrimitive =
DataPrimitiveArray
inKnownModule :: IsKnownPkg pkg
=> KnownModule pkg
-> FlatClosure -> Maybe String
inKnownModule :: forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule pkg
modl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested KnownModule pkg
modl
inKnownModuleNested :: IsKnownPkg pkg
=> KnownModule pkg
-> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested :: forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested = forall (pkg :: KnownPkg).
SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go forall (pkg :: KnownPkg). IsKnownPkg pkg => SPkg pkg
singPkg
where
go :: SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go :: forall (pkg :: KnownPkg).
SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go SPkg pkg
knownPkg KnownModule pkg
knownModl ConstrClosure{String
pkg :: FlatClosure -> String
pkg :: String
pkg, String
modl :: FlatClosure -> String
modl :: String
modl, String
name :: FlatClosure -> String
name :: String
name, [Box]
ptrArgs :: FlatClosure -> [Box]
ptrArgs :: [Box]
ptrArgs} = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> String
stripVowels (forall (pkg :: KnownPkg). SPkg pkg -> String
namePkg SPkg pkg
knownPkg) forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
stripVowels String
pkg)
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
modl forall a. Eq a => a -> a -> Bool
== forall (pkg :: KnownPkg). SPkg pkg -> KnownModule pkg -> String
nameModl SPkg pkg
knownPkg KnownModule pkg
knownModl)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Box]
ptrArgs)
go SPkg pkg
_ KnownModule pkg
_ FlatClosure
_otherClosure = forall a. Maybe a
Nothing
namePkg :: SPkg pkg -> String
namePkg :: forall (pkg :: KnownPkg). SPkg pkg -> String
namePkg SPkg pkg
SGhcPrim = String
"ghc-prim"
namePkg SPkg pkg
SBase = String
"base"
namePkg SPkg pkg
SByteString = String
"bytestring"
namePkg SPkg pkg
SText = String
"text"
namePkg SPkg pkg
SIntegerWiredIn = String
"integer-wired-in"
namePkg SPkg pkg
SGhcBignum = String
"ghc-bignum"
namePkg SPkg pkg
SContainers = String
"containers"
namePkg SPkg pkg
SAeson = String
"aeson"
namePkg SPkg pkg
SUnorderedContainers = String
"unordered-containers"
namePkg SPkg pkg
SVector = String
"vector"
namePkg SPkg pkg
SPrimitive = String
"primitive"
nameModl :: SPkg pkg -> KnownModule pkg -> String
nameModl :: forall (pkg :: KnownPkg). SPkg pkg -> KnownModule pkg -> String
nameModl = \case
SPkg pkg
SGhcPrim -> \case
KnownModule pkg
R:KnownModulePkgGhcPrim
GhcTypes -> String
"GHC.Types"
#if MIN_VERSION_ghc_prim(0,10,0)
GhcTuple -> "GHC.Tuple.Prim"
#else
KnownModule pkg
R:KnownModulePkgGhcPrim
GhcTuple -> String
"GHC.Tuple"
#endif
SPkg pkg
SBase -> \case
KnownModule pkg
R:KnownModulePkgBase
GhcInt -> String
"GHC.Int"
KnownModule pkg
R:KnownModulePkgBase
GhcWord -> String
"GHC.Word"
KnownModule pkg
R:KnownModulePkgBase
GhcSTRef -> String
"GHC.STRef"
KnownModule pkg
R:KnownModulePkgBase
GhcMVar -> String
"GHC.MVar"
KnownModule pkg
R:KnownModulePkgBase
GhcConcSync -> String
"GHC.Conc.Sync"
KnownModule pkg
R:KnownModulePkgBase
GhcMaybe -> String
"GHC.Maybe"
KnownModule pkg
R:KnownModulePkgBase
GhcReal -> String
"GHC.Real"
KnownModule pkg
R:KnownModulePkgBase
DataEither -> String
"Data.Either"
SPkg pkg
SByteString -> \case
#if MIN_VERSION_bytestring(0,11,4)
DataByteStringInternal -> "Data.ByteString.Internal.Type"
#else
KnownModule pkg
R:KnownModulePkgByteString
DataByteStringInternal -> String
"Data.ByteString.Internal"
#endif
KnownModule pkg
R:KnownModulePkgByteString
DataByteStringLazyInternal -> String
"Data.ByteString.Lazy.Internal"
KnownModule pkg
R:KnownModulePkgByteString
DataByteStringShortInternal -> String
"Data.ByteString.Short.Internal"
SPkg pkg
SText -> \case
KnownModule pkg
R:KnownModulePkgText
DataTextInternal -> String
"Data.Text.Internal"
KnownModule pkg
R:KnownModulePkgText
DataTextInternalLazy -> String
"Data.Text.Internal.Lazy"
SPkg pkg
SIntegerWiredIn -> \case
KnownModule pkg
R:KnownModulePkgIntegerWiredIn
GhcIntegerType -> String
"GHC.Integer.Type"
SPkg pkg
SGhcBignum -> \case
KnownModule pkg
R:KnownModulePkgGhcBignum
GhcNumInteger -> String
"GHC.Num.Integer"
SPkg pkg
SContainers -> \case
KnownModule pkg
R:KnownModulePkgContainers
DataSetInternal -> String
"Data.Set.Internal"
KnownModule pkg
R:KnownModulePkgContainers
DataMapInternal -> String
"Data.Map.Internal"
KnownModule pkg
R:KnownModulePkgContainers
DataIntSetInternal -> String
"Data.IntSet.Internal"
KnownModule pkg
R:KnownModulePkgContainers
DataIntMapInternal -> String
"Data.IntMap.Internal"
KnownModule pkg
R:KnownModulePkgContainers
DataSequenceInternal -> String
"Data.Sequence.Internal"
KnownModule pkg
R:KnownModulePkgContainers
DataTree -> String
"Data.Tree"
SPkg pkg
SAeson -> \case
KnownModule pkg
R:KnownModulePkgAeson
DataAesonTypesInternal -> String
"Data.Aeson.Types.Internal"
SPkg pkg
SUnorderedContainers -> \case
KnownModule pkg
R:KnownModulePkgUnorderedContainers
DataHashMapInternal -> String
"Data.HashMap.Internal"
KnownModule pkg
R:KnownModulePkgUnorderedContainers
DataHashMapInternalArray -> String
"Data.HashMap.Internal.Array"
SPkg pkg
SVector -> \case
KnownModule pkg
R:KnownModulePkgVector
DataVector -> String
"Data.Vector"
KnownModule pkg
R:KnownModulePkgVector
DataVectorStorable -> String
"Data.Vector.Storable"
KnownModule pkg
R:KnownModulePkgVector
DataVectorStorableMutable -> String
"Data.Vector.Storable.Mutable"
KnownModule pkg
R:KnownModulePkgVector
DataVectorPrimitive -> String
"Data.Vector.Primitive"
KnownModule pkg
R:KnownModulePkgVector
DataVectorPrimitiveMutable -> String
"Data.Vector.Primitive.Mutable"
SPkg pkg
SPrimitive -> \case
KnownModule pkg
R:KnownModulePkgPrimitive
DataPrimitiveArray -> String
"Data.Primitive.Array"
stripVowels :: String -> String
stripVowels :: String -> String
stripVowels = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"aeoiu")