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

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

import Control.Monad
import Data.List (isPrefixOf)

import Debug.RecoverRTTI.FlatClosure
import Debug.RecoverRTTI.Util.TypeLevel

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

data KnownPkg =
    PkgGhcPrim
  | PkgBase
  | PkgByteString
  | PkgText
  | PkgIntegerWiredIn
  | PkgGhcBignum
  | PkgContainers
  | PkgAeson

data family KnownModule (pkg :: KnownPkg)

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

data instance Sing (pkg :: KnownPkg) where
  SGhcPrim        :: Sing 'PkgGhcPrim
  SBase           :: Sing 'PkgBase
  SByteString     :: Sing 'PkgByteString
  SText           :: Sing 'PkgText
  SIntegerWiredIn :: Sing 'PkgIntegerWiredIn
  SGhcBignum      :: Sing 'PkgGhcBignum
  SContainers     :: Sing 'PkgContainers
  SAeson          :: Sing 'PkgAeson

instance SingI 'PkgGhcPrim        where sing :: Sing 'PkgGhcPrim
sing = Sing 'PkgGhcPrim
SGhcPrim
instance SingI 'PkgBase           where sing :: Sing 'PkgBase
sing = Sing 'PkgBase
SBase
instance SingI 'PkgByteString     where sing :: Sing 'PkgByteString
sing = Sing 'PkgByteString
SByteString
instance SingI 'PkgText           where sing :: Sing 'PkgText
sing = Sing 'PkgText
SText
instance SingI 'PkgIntegerWiredIn where sing :: Sing 'PkgIntegerWiredIn
sing = Sing 'PkgIntegerWiredIn
SIntegerWiredIn
instance SingI 'PkgGhcBignum      where sing :: Sing 'PkgGhcBignum
sing = Sing 'PkgGhcBignum
SGhcBignum
instance SingI 'PkgContainers     where sing :: Sing 'PkgContainers
sing = Sing 'PkgContainers
SContainers
instance SingI 'PkgAeson          where sing :: Sing 'PkgAeson
sing = Sing 'PkgAeson
SAeson

{-------------------------------------------------------------------------------
  Modules in @ghc-pri@
-------------------------------------------------------------------------------}

data instance KnownModule 'PkgGhcPrim =
    GhcTypes
  | GhcTuple

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

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

{-------------------------------------------------------------------------------
  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

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

-- | Check if the given closure is from a known package/module
inKnownModule :: SingI pkg
  => KnownModule pkg
  -> FlatClosure -> Maybe String
inKnownModule :: KnownModule pkg -> FlatClosure -> Maybe String
inKnownModule KnownModule pkg
modl = ((String, [Box]) -> String)
-> Maybe (String, [Box]) -> Maybe String
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).
SingI pkg =>
KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested KnownModule pkg
modl

-- | Generalization of 'inKnownModule' that additionally returns nested pointers
inKnownModuleNested :: SingI pkg
  => KnownModule pkg
  -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested :: KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
inKnownModuleNested = Sing pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
forall (pkg :: KnownPkg).
Sing pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go Sing pkg
forall k (a :: k). SingI a => Sing a
sing
  where
    go :: Sing pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
    go :: Sing pkg -> KnownModule pkg -> FlatClosure -> Maybe (String, [Box])
go Sing 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
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Sing pkg -> String
forall (pkg :: KnownPkg). Sing pkg -> String
namePkg Sing pkg
knownPkg String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
pkg) -- ignore the version number
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
modl String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Sing pkg -> KnownModule pkg -> String
forall (pkg :: KnownPkg). Sing pkg -> KnownModule pkg -> String
nameModl Sing pkg
knownPkg KnownModule pkg
knownModl)
        (String, [Box]) -> Maybe (String, [Box])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Box]
ptrArgs)
    go Sing pkg
_ KnownModule pkg
_ FlatClosure
_otherClosure = Maybe (String, [Box])
forall a. Maybe a
Nothing

    namePkg :: Sing (pkg :: KnownPkg) -> String
    namePkg :: Sing pkg -> String
namePkg Sing pkg
SGhcPrim        = String
"ghc-prim"
    namePkg Sing pkg
SBase           = String
"base"
    namePkg Sing pkg
SByteString     = String
"bytestring"
    namePkg Sing pkg
SText           = String
"text"
    namePkg Sing pkg
SIntegerWiredIn = String
"integer-wired-in"
    namePkg Sing pkg
SGhcBignum      = String
"ghc-bignum"
    namePkg Sing pkg
SContainers     = String
"containers"
    namePkg Sing pkg
SAeson          = String
"aeson"

    nameModl :: Sing (pkg :: KnownPkg) -> KnownModule pkg -> String
    nameModl :: Sing pkg -> KnownModule pkg -> String
nameModl Sing pkg
SGhcPrim        KnownModule pkg
GhcTypes                    = String
"GHC.Types"
    nameModl Sing pkg
SGhcPrim        KnownModule pkg
GhcTuple                    = String
"GHC.Tuple"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcInt                      = String
"GHC.Int"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcWord                     = String
"GHC.Word"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcSTRef                    = String
"GHC.STRef"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcMVar                     = String
"GHC.MVar"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcConcSync                 = String
"GHC.Conc.Sync"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcMaybe                    = String
"GHC.Maybe"
    nameModl Sing pkg
SBase           KnownModule pkg
GhcReal                     = String
"GHC.Real"
    nameModl Sing pkg
SBase           KnownModule pkg
DataEither                  = String
"Data.Either"
    nameModl Sing pkg
SByteString     KnownModule pkg
DataByteStringInternal      = String
"Data.ByteString.Internal"
    nameModl Sing pkg
SByteString     KnownModule pkg
DataByteStringLazyInternal  = String
"Data.ByteString.Lazy.Internal"
    nameModl Sing pkg
SByteString     KnownModule pkg
DataByteStringShortInternal = String
"Data.ByteString.Short.Internal"
    nameModl Sing pkg
SText           KnownModule pkg
DataTextInternal            = String
"Data.Text.Internal"
    nameModl Sing pkg
SText           KnownModule pkg
DataTextInternalLazy        = String
"Data.Text.Internal.Lazy"
    nameModl Sing pkg
SIntegerWiredIn KnownModule pkg
GhcIntegerType              = String
"GHC.Integer.Type"
    nameModl Sing pkg
SGhcBignum      KnownModule pkg
GhcNumInteger               = String
"GHC.Num.Integer"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataSetInternal             = String
"Data.Set.Internal"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataMapInternal             = String
"Data.Map.Internal"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataIntSetInternal          = String
"Data.IntSet.Internal"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataIntMapInternal          = String
"Data.IntMap.Internal"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataSequenceInternal        = String
"Data.Sequence.Internal"
    nameModl Sing pkg
SContainers     KnownModule pkg
DataTree                    = String
"Data.Tree"
    nameModl Sing pkg
SAeson          KnownModule pkg
DataAesonTypesInternal      = String
"Data.Aeson.Types.Internal"