module Hint.Reflection (
      ModuleElem(..), Id, name, children,
      getModuleExports,
) where

import Data.List
import Data.Maybe

import Hint.Base
import qualified Hint.GHC as GHC

-- | An Id for a class, a type constructor, a data constructor, a binding, etc
type Id = String

data ModuleElem = Fun Id | Class Id [Id] | Data Id [Id]
  deriving (ReadPrec [ModuleElem]
ReadPrec ModuleElem
Int -> ReadS ModuleElem
ReadS [ModuleElem]
(Int -> ReadS ModuleElem)
-> ReadS [ModuleElem]
-> ReadPrec ModuleElem
-> ReadPrec [ModuleElem]
-> Read ModuleElem
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ModuleElem
readsPrec :: Int -> ReadS ModuleElem
$creadList :: ReadS [ModuleElem]
readList :: ReadS [ModuleElem]
$creadPrec :: ReadPrec ModuleElem
readPrec :: ReadPrec ModuleElem
$creadListPrec :: ReadPrec [ModuleElem]
readListPrec :: ReadPrec [ModuleElem]
Read, Int -> ModuleElem -> ShowS
[ModuleElem] -> ShowS
ModuleElem -> [Char]
(Int -> ModuleElem -> ShowS)
-> (ModuleElem -> [Char])
-> ([ModuleElem] -> ShowS)
-> Show ModuleElem
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ModuleElem -> ShowS
showsPrec :: Int -> ModuleElem -> ShowS
$cshow :: ModuleElem -> [Char]
show :: ModuleElem -> [Char]
$cshowList :: [ModuleElem] -> ShowS
showList :: [ModuleElem] -> ShowS
Show, ModuleElem -> ModuleElem -> Bool
(ModuleElem -> ModuleElem -> Bool)
-> (ModuleElem -> ModuleElem -> Bool) -> Eq ModuleElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModuleElem -> ModuleElem -> Bool
== :: ModuleElem -> ModuleElem -> Bool
$c/= :: ModuleElem -> ModuleElem -> Bool
/= :: ModuleElem -> ModuleElem -> Bool
Eq)

name :: ModuleElem -> Id
name :: ModuleElem -> [Char]
name (Fun [Char]
f)     = [Char]
f
name (Class [Char]
c [[Char]]
_) = [Char]
c
name (Data [Char]
d [[Char]]
_)  = [Char]
d

children :: ModuleElem -> [Id]
children :: ModuleElem -> [[Char]]
children (Fun   [Char]
_)     = []
children (Class [Char]
_ [[Char]]
ms)  = [[Char]]
ms
children (Data  [Char]
_ [[Char]]
dcs) = [[Char]]
dcs

-- | Gets an abstract representation of all the entities exported by the module.
--   It is similar to the @:browse@ command in GHCi.
getModuleExports :: MonadInterpreter m => ModuleName -> m [ModuleElem]
getModuleExports :: forall (m :: * -> *).
MonadInterpreter m =>
[Char] -> m [ModuleElem]
getModuleExports [Char]
mn =
    do module_  <- [Char] -> m Module
forall (m :: * -> *). MonadInterpreter m => [Char] -> m Module
findModule [Char]
mn
       mod_info <- mayFail $ runGhc $ GHC.getModuleInfo module_
       exports  <- mapM (\Name
n -> RunGhc m (Maybe TyThing)
forall a. RunGhc m a
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc RunGhc m (Maybe TyThing) -> RunGhc m (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ Name -> GhcT n (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName Name
n) (GHC.modInfoExports mod_info)
       dflags   <- runGhc GHC.getSessionDynFlags
       --
       return $ asModElemList dflags (catMaybes exports)

asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem]
asModElemList :: DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
df [TyThing]
xs = [[ModuleElem]] -> [ModuleElem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                        [ModuleElem]
cs,
                        [ModuleElem]
ts,
                        [ModuleElem]
ds [ModuleElem] -> [ModuleElem] -> [ModuleElem]
forall a. Eq a => [a] -> [a] -> [a]
\\ (ModuleElem -> [ModuleElem]) -> [ModuleElem] -> [ModuleElem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> ModuleElem) -> [[Char]] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ModuleElem
Fun ([[Char]] -> [ModuleElem])
-> (ModuleElem -> [[Char]]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [[Char]]
children) [ModuleElem]
ts,
                        [ModuleElem]
fs [ModuleElem] -> [ModuleElem] -> [ModuleElem]
forall a. Eq a => [a] -> [a] -> [a]
\\ (ModuleElem -> [ModuleElem]) -> [ModuleElem] -> [ModuleElem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> ModuleElem) -> [[Char]] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ModuleElem
Fun ([[Char]] -> [ModuleElem])
-> (ModuleElem -> [[Char]]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [[Char]]
children) [ModuleElem]
cs
                      ]
    where cs :: [ModuleElem]
cs = [[Char] -> [[Char]] -> ModuleElem
Class (DynFlags -> TyCon -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df TyCon
tc) (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> [Char] -> Bool
alsoIn [ModuleElem]
fs) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df (Id -> [Char]) -> [Id] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Class -> [Id]
GHC.classMethods Class
c)
               | GHC.ATyCon TyCon
tc <- [TyThing]
xs, Just Class
c  <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ts :: [ModuleElem]
ts = [[Char] -> [[Char]] -> ModuleElem
Data  (DynFlags -> TyCon -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df TyCon
tc) (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> [Char] -> Bool
alsoIn [ModuleElem]
ds) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df (DataCon -> [Char]) -> [DataCon] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> [DataCon]
GHC.tyConDataCons TyCon
tc)
               | GHC.ATyCon TyCon
tc <- [TyThing]
xs, Maybe Class
Nothing <- [TyCon -> Maybe Class
GHC.tyConClass_maybe TyCon
tc]]
          ds :: [ModuleElem]
ds = [[Char] -> ModuleElem
Fun ([Char] -> ModuleElem) -> [Char] -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df DataCon
dc | GHC.AConLike (GHC.RealDataCon DataCon
dc) <- [TyThing]
xs]
          fs :: [ModuleElem]
fs = [[Char] -> ModuleElem
Fun ([Char] -> ModuleElem) -> [Char] -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> [Char]
forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
df Id
f  | GHC.AnId Id
f                        <- [TyThing]
xs]
          alsoIn :: [ModuleElem] -> [Char] -> Bool
alsoIn [ModuleElem]
es = ([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ModuleElem -> [Char]) -> [ModuleElem] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ModuleElem -> [Char]
name [ModuleElem]
es)

getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String
getUnqualName :: forall a. NamedThing a => DynFlags -> a -> [Char]
getUnqualName DynFlags
dfs = DynFlags -> SDoc -> [Char]
GHC.showSDoc DynFlags
dfs (SDoc -> [Char]) -> (a -> SDoc) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. NamedThing a => a -> SDoc
GHC.pprParenSymName