{-# LANGUAGE CPP            #-}
{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE GADTs          #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase     #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies   #-}

-- | Modules we recognize types from
module Debug.RecoverRTTI.Modules (
    KnownPkg(..)
  , KnownModule(..)
  , IsKnownPkg(..)
    -- * Matching
  , inKnownModule
  , inKnownModuleNested
  ) where

import Control.Monad
import Data.List (isPrefixOf)

import Debug.RecoverRTTI.FlatClosure

{-------------------------------------------------------------------------------
  Packages
-------------------------------------------------------------------------------}

data KnownPkg =
    PkgGhcPrim
#if MIN_VERSION_base(4,20,0)
  | PkgGhcInternal
#endif
  | PkgBase
#if !MIN_VERSION_base(4,17,0)
  | PkgDataArrayByte
#endif
  | PkgByteString
  | PkgText
  | PkgIntegerWiredIn
  | PkgGhcBignum
  | PkgContainers
  | PkgAeson
  | PkgUnorderedContainers
  | PkgVector
  | PkgPrimitive

data family KnownModule (pkg :: KnownPkg)

{-------------------------------------------------------------------------------
  Singleton instance for KnownPkg
-------------------------------------------------------------------------------}

data SPkg (pkg :: KnownPkg) where
  SGhcPrim             :: SPkg 'PkgGhcPrim
#if MIN_VERSION_base(4,20,0)
  SGhcInternal         :: SPkg 'PkgGhcInternal
#endif
  SBase                :: SPkg 'PkgBase
#if !MIN_VERSION_base(4,17,0)
  SDataArrayByte       :: SPkg 'PkgDataArrayByte
#endif
  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
#if MIN_VERSION_base(4,20,0)
instance IsKnownPkg 'PkgGhcInternal         where singPkg = SGhcInternal
#endif
instance IsKnownPkg 'PkgBase                where singPkg :: SPkg 'PkgBase
singPkg = SPkg 'PkgBase
SBase
#if !MIN_VERSION_base(4,17,0)
instance IsKnownPkg 'PkgDataArrayByte       where singPkg = SDataArrayByte
#endif
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

{-------------------------------------------------------------------------------
  Modules in @ghc-prim@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgGhcPrim =
    GhcTypes
  | GhcTuple

{-------------------------------------------------------------------------------
  Modules in @ghc-internal@ (ghc 9.10 and up)
-------------------------------------------------------------------------------}

#if MIN_VERSION_base(4,20,0)
data instance KnownModule 'PkgGhcInternal =
    GhcInt
  | GhcWord
  | GhcSTRef
  | GhcMVar
  | GhcConcSync
  | GhcMaybe
  | GhcReal
  | DataEither
#endif

{-------------------------------------------------------------------------------
  Modules in @base@
-------------------------------------------------------------------------------}


#if MIN_VERSION_base(4,20,0)

data instance KnownModule 'PkgBase =
    DataArrayByte

#else

data instance KnownModule 'PkgBase =
    GhcInt
  | GhcWord
  | GhcSTRef
  | GhcMVar
  | GhcConcSync
  | GhcMaybe
  | GhcReal
  | DataEither

#if MIN_VERSION_base(4,17,0)
  | DataArrayByte
#else
data instance KnownModule 'PkgDataArrayByte =
    DataArrayByte
#endif

#endif

{-------------------------------------------------------------------------------
  Modules in @bytestring@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgByteString =
    DataByteStringInternal
  | DataByteStringLazyInternal
  | DataByteStringShortInternal

{-------------------------------------------------------------------------------
  Modules in @text@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgText =
    DataTextInternal
  | DataTextInternalLazy

{-------------------------------------------------------------------------------
  Modules in @integer-wired-in@ (this is a virtual package)
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgIntegerWiredIn =
    GhcIntegerType

{-------------------------------------------------------------------------------
  Modules in @ghc-bignum@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgGhcBignum =
    GhcNumInteger

{-------------------------------------------------------------------------------
  Modules in @containers@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgContainers =
    DataSetInternal
  | DataMapInternal
  | DataIntSetInternal
  | DataIntMapInternal
  | DataSequenceInternal
  | DataTree

{-------------------------------------------------------------------------------
  Modules in @aeson@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgAeson =
    DataAesonTypesInternal

{-------------------------------------------------------------------------------
  Modules in @unordered-containers@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgUnorderedContainers =
    DataHashMapInternal
  | DataHashMapInternalArray

{-------------------------------------------------------------------------------
  Modules in @vector@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgVector =
    DataVector
  | DataVectorStorable
  | DataVectorStorableMutable
  | DataVectorPrimitive
  | DataVectorPrimitiveMutable

{-------------------------------------------------------------------------------
  Modules in @primitive@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgPrimitive =
    DataPrimitiveArray
  | DataPrimitiveByteArray

{-------------------------------------------------------------------------------
  Matching
-------------------------------------------------------------------------------}

-- | Check if the given closure is from a known package/module
inKnownModule :: IsKnownPkg pkg
  => KnownModule pkg
  -> FlatClosure -> Maybe String
inKnownModule :: forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule pkg
modl = ((String, [Box]) -> String)
-> Maybe (String, [Box]) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, [Box]) -> String
forall a b. (a, b) -> a
fst (Maybe (String, [Box]) -> Maybe String)
-> (FlatClosure -> Maybe (String, [Box]))
-> FlatClosure
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested KnownModule pkg
modl

-- | Generalization of 'inKnownModule' that additionally returns nested pointers
inKnownModuleNested :: IsKnownPkg pkg
  => KnownModule pkg
  -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested :: forall (pkg :: KnownPkg).
IsKnownPkg pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested = SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
forall (pkg :: KnownPkg).
SPkg pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go SPkg pkg
forall (pkg :: KnownPkg). IsKnownPkg pkg => SPkg pkg
singPkg
  where
    -- We ignore the package version: we assume that we are linked against only
    -- a single version of each package, and that those versions are statically
    -- known (that is, we can use CPP where necessary).
    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 :: String
pkg :: FlatClosure -> String
pkg, String
modl :: String
modl :: FlatClosure -> String
modl, String
name :: String
name :: FlatClosure -> String
name, [Box]
ptrArgs :: [Box]
ptrArgs :: FlatClosure -> [Box]
ptrArgs} = do
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> String
stripVowels (SPkg pkg -> String
forall (pkg :: KnownPkg). SPkg pkg -> String
namePkg SPkg pkg
knownPkg) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
stripVowels String
pkg)
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
modl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== SPkg pkg -> KnownModule pkg -> String
forall (pkg :: KnownPkg). SPkg pkg -> KnownModule pkg -> String
nameModl SPkg pkg
knownPkg KnownModule pkg
knownModl)
        (String, [Box]) -> Maybe (String, [Box])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Box]
ptrArgs)
    go SPkg pkg
_ KnownModule pkg
_ FlatClosure
_otherClosure = Maybe (String, [Box])
forall a. Maybe a
Nothing

    namePkg :: SPkg pkg -> String
    namePkg :: forall (pkg :: KnownPkg). SPkg pkg -> String
namePkg SPkg pkg
SGhcPrim             = String
"ghc-prim"
#if MIN_VERSION_base(4,20,0)
    namePkg SGhcInternal         = "ghc-internal"
#endif
    namePkg SPkg pkg
SBase                = String
"base"
#if !MIN_VERSION_base(4,17,0)
    namePkg SDataArrayByte       = "data-array-byte"
#endif
    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_base(4,20,0)
          GhcTuple -> "GHC.Tuple"
#elif MIN_VERSION_ghc_prim(0,10,0)
          KnownModule pkg
R:KnownModulePkgGhcPrim
GhcTuple -> String
"GHC.Tuple.Prim"
#else
          GhcTuple -> "GHC.Tuple"
#endif

#if MIN_VERSION_base(4,20,0)
        SGhcInternal -> \case
          GhcInt      -> "GHC.Internal.Int"
          GhcWord     -> "GHC.Internal.Word"
          GhcSTRef    -> "GHC.Internal.STRef"
          GhcMVar     -> "GHC.Internal.MVar"
          GhcConcSync -> "GHC.Internal.Conc.Sync"
          GhcMaybe    -> "GHC.Internal.Maybe"
          GhcReal     -> "GHC.Internal.Real"
          DataEither  -> "GHC.Internal.Data.Either"
#endif

        SPkg pkg
SBase -> \case
#if !MIN_VERSION_base(4,20,0)
          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"
#endif
#if MIN_VERSION_base(4,17,0)
          KnownModule pkg
R:KnownModulePkgBase
DataArrayByte -> String
"Data.Array.Byte"
#else
        SDataArrayByte -> \case
          DataArrayByte -> "Data.Array.Byte"
#endif

        SPkg pkg
SByteString -> \case
#if MIN_VERSION_bytestring(0,11,4)
          KnownModule pkg
R:KnownModulePkgByteString
DataByteStringInternal      -> String
"Data.ByteString.Internal.Type"
#else
          DataByteStringInternal      -> "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"
          KnownModule pkg
R:KnownModulePkgPrimitive
DataPrimitiveByteArray -> String
"Data.Primitive.ByteArray"

    -- On OSX, cabal strips vowels from package IDs in order to work around
    -- limitations around path lengths
    -- <https://github.com/haskell/cabal/blob/3f397c0c661facd0be9c5c67ad26f66a87725472/cabal-install/src/Distribution/Client/PackageHash.hs#L125-L157>
    stripVowels :: String -> String
    stripVowels :: String -> String
stripVowels = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"aeoiu")