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
readListPrec :: ReadPrec [ModuleElem]
$creadListPrec :: ReadPrec [ModuleElem]
readPrec :: ReadPrec ModuleElem
$creadPrec :: ReadPrec ModuleElem
readList :: ReadS [ModuleElem]
$creadList :: ReadS [ModuleElem]
readsPrec :: Int -> ReadS ModuleElem
$creadsPrec :: Int -> ReadS ModuleElem
Read, Int -> ModuleElem -> ShowS
[ModuleElem] -> ShowS
ModuleElem -> String
(Int -> ModuleElem -> ShowS)
-> (ModuleElem -> String)
-> ([ModuleElem] -> ShowS)
-> Show ModuleElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ModuleElem] -> ShowS
$cshowList :: [ModuleElem] -> ShowS
show :: ModuleElem -> String
$cshow :: ModuleElem -> String
showsPrec :: Int -> ModuleElem -> ShowS
$cshowsPrec :: Int -> ModuleElem -> ShowS
Show, ModuleElem -> ModuleElem -> Bool
(ModuleElem -> ModuleElem -> Bool)
-> (ModuleElem -> ModuleElem -> Bool) -> Eq ModuleElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleElem -> ModuleElem -> Bool
$c/= :: ModuleElem -> ModuleElem -> Bool
== :: ModuleElem -> ModuleElem -> Bool
$c== :: ModuleElem -> ModuleElem -> Bool
Eq)

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

children :: ModuleElem -> [Id]
children :: ModuleElem -> [String]
children (Fun   _)     = []
children (Class _ ms :: [String]
ms)  = [String]
ms
children (Data  _ dcs :: [String]
dcs) = [String]
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 :: String -> m [ModuleElem]
getModuleExports mn :: String
mn =
    do Module
module_  <- String -> m Module
forall (m :: * -> *). MonadInterpreter m => String -> m Module
findModule String
mn
       ModuleInfo
mod_info <- m (Maybe ModuleInfo) -> m ModuleInfo
forall (m :: * -> *) a. MonadInterpreter m => m (Maybe a) -> m a
mayFail (m (Maybe ModuleInfo) -> m ModuleInfo)
-> m (Maybe ModuleInfo) -> m ModuleInfo
forall a b. (a -> b) -> a -> b
$ RunGhc1 m Module (Maybe ModuleInfo)
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
Module -> GhcT n (Maybe ModuleInfo)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
module_
       [Maybe TyThing]
exports  <- (Name -> m (Maybe TyThing)) -> [Name] -> m [Maybe TyThing]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RunGhc1 m Name (Maybe TyThing)
forall (m :: * -> *) a b. MonadInterpreter m => RunGhc1 m a b
runGhc1 forall (n :: * -> *).
(MonadIO n, MonadMask n) =>
Name -> GhcT n (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName) (ModuleInfo -> [Name]
GHC.modInfoExports ModuleInfo
mod_info)
       DynFlags
dflags   <- RunGhc m DynFlags
forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
       --
       [ModuleElem] -> m [ModuleElem]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ModuleElem] -> m [ModuleElem]) -> [ModuleElem] -> m [ModuleElem]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [TyThing] -> [ModuleElem]
asModElemList DynFlags
dflags ([Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes [Maybe TyThing]
exports)

asModElemList :: GHC.DynFlags -> [GHC.TyThing] -> [ModuleElem]
asModElemList :: DynFlags -> [TyThing] -> [ModuleElem]
asModElemList df :: DynFlags
df xs :: [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 ((String -> ModuleElem) -> [String] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map String -> ModuleElem
Fun ([String] -> [ModuleElem])
-> (ModuleElem -> [String]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [String]
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 ((String -> ModuleElem) -> [String] -> [ModuleElem]
forall a b. (a -> b) -> [a] -> [b]
map String -> ModuleElem
Fun ([String] -> [ModuleElem])
-> (ModuleElem -> [String]) -> ModuleElem -> [ModuleElem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleElem -> [String]
children) [ModuleElem]
cs'
                      ]
    where (cs :: [ModuleElem]
cs,ts :: [ModuleElem]
ts,ds :: [ModuleElem]
ds,fs :: [ModuleElem]
fs) =
           (
             [DynFlags -> TyThing -> ModuleElem
asModElem DynFlags
df TyThing
c | c :: TyThing
c@(GHC.ATyCon c' :: TyCon
c') <- [TyThing]
xs, TyCon -> Bool
GHC.isClassTyCon TyCon
c'],
             [DynFlags -> TyThing -> ModuleElem
asModElem DynFlags
df TyThing
t | t :: TyThing
t@(GHC.ATyCon c' :: TyCon
c') <- [TyThing]
xs, (Bool -> Bool
not (Bool -> Bool) -> (TyCon -> Bool) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Bool
GHC.isClassTyCon) TyCon
c'],
             [DynFlags -> TyThing -> ModuleElem
asModElem DynFlags
df TyThing
d | d :: TyThing
d@(GHC.AConLike GHC.RealDataCon{}) <- [TyThing]
xs],
             [DynFlags -> TyThing -> ModuleElem
asModElem DynFlags
df TyThing
f | f :: TyThing
f@GHC.AnId{} <- [TyThing]
xs]
           )
          cs' :: [ModuleElem]
cs' = [String -> [String] -> ModuleElem
Class String
n ([String] -> ModuleElem) -> [String] -> ModuleElem
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> String -> Bool
alsoIn [ModuleElem]
fs) [String]
ms  | Class n :: String
n ms :: [String]
ms  <- [ModuleElem]
cs]
          ts' :: [ModuleElem]
ts' = [String -> [String] -> ModuleElem
Data  String
t ([String] -> ModuleElem) -> [String] -> ModuleElem
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ([ModuleElem] -> String -> Bool
alsoIn [ModuleElem]
ds) [String]
dcs | Data  t :: String
t dcs :: [String]
dcs <- [ModuleElem]
ts]
          alsoIn :: [ModuleElem] -> String -> Bool
alsoIn es :: [ModuleElem]
es = (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ModuleElem -> String) -> [ModuleElem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleElem -> String
name [ModuleElem]
es)

asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem
asModElem :: DynFlags -> TyThing -> ModuleElem
asModElem df :: DynFlags
df (GHC.AnId f :: Id
f)      = String -> ModuleElem
Fun (String -> ModuleElem) -> String -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> Id -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df Id
f
asModElem df :: DynFlags
df (GHC.AConLike (GHC.RealDataCon dc :: DataCon
dc)) = String -> ModuleElem
Fun (String -> ModuleElem) -> String -> ModuleElem
forall a b. (a -> b) -> a -> b
$ DynFlags -> DataCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df DataCon
dc
asModElem df :: DynFlags
df (GHC.ATyCon tc :: TyCon
tc)   =
  if TyCon -> Bool
GHC.isClassTyCon TyCon
tc
  then String -> [String] -> ModuleElem
Class (DynFlags -> TyCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df TyCon
tc) ((Id -> String) -> [Id] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Id -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df) ([Id] -> [String]) -> [Id] -> [String]
forall a b. (a -> b) -> a -> b
$ (Class -> [Id]
GHC.classMethods (Class -> [Id]) -> (TyCon -> Class) -> TyCon -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Class -> Class
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Class -> Class) -> (TyCon -> Maybe Class) -> TyCon -> Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Maybe Class
GHC.tyConClass_maybe) TyCon
tc)
  else String -> [String] -> ModuleElem
Data  (DynFlags -> TyCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df TyCon
tc) ((DataCon -> String) -> [DataCon] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> DataCon -> String
forall a. NamedThing a => DynFlags -> a -> String
getUnqualName DynFlags
df) ([DataCon] -> [String]) -> [DataCon] -> [String]
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
GHC.tyConDataCons TyCon
tc)
asModElem _ _ = String -> ModuleElem
forall a. HasCallStack => String -> a
error "asModElem: can't happen!"

getUnqualName :: GHC.NamedThing a => GHC.DynFlags -> a -> String
getUnqualName :: DynFlags -> a -> String
getUnqualName dfs :: DynFlags
dfs = DynFlags -> SDoc -> String
GHC.showSDocUnqual DynFlags
dfs (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. NamedThing a => a -> SDoc
GHC.pprParenSymName