module Hhp.Things (
    GapThing(..)
  , fromTyThing
  , infoThing
  ) where

import GHC (Type, TyCon, Ghc, Fixity, TyThing)
import qualified GHC as G
import GHC.Core.ConLike (ConLike(..))
import GHC.Core.DataCon (dataConNonlinearType)
import GHC.Core.FamInstEnv (pprFamInsts)
import qualified GHC.Core.InstEnv as InstEnv
import GHC.Core.PatSyn (PatSyn)
import GHC.Types.Name.Set (elemNameSet, mkNameSet)
import GHC.Types.Var (varType)
import GHC.Utils.Outputable as Outputable

import Data.List (intersperse)
import Data.Maybe (catMaybes)

import Hhp.Gap

----------------------------------------------------------------

data GapThing = GtA Type
              | GtT TyCon
              | GtN
              | GtPatSyn PatSyn

fromTyThing :: TyThing -> GapThing
fromTyThing :: TyThing -> GapThing
fromTyThing (G.AnId Id
i)                   = Type -> GapThing
GtA forall a b. (a -> b) -> a -> b
$ Id -> Type
varType Id
i
fromTyThing (G.AConLike (RealDataCon DataCon
d)) = Type -> GapThing
GtA forall a b. (a -> b) -> a -> b
$ DataCon -> Type
dataConNonlinearType DataCon
d
fromTyThing (G.AConLike (PatSynCon PatSyn
p))   = PatSyn -> GapThing
GtPatSyn PatSyn
p
fromTyThing (G.ATyCon TyCon
t)                 = TyCon -> GapThing
GtT TyCon
t
fromTyThing TyThing
_                            = GapThing
GtN

----------------------------------------------------------------

infoThing :: String -> Ghc SDoc
infoThing :: String -> Ghc SDoc
infoThing String
str = do
    [Name]
names <- forall (m :: * -> *). GhcMonad m => String -> m [Name]
G.parseName String
str
    [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
mb_stuffs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
GhcMonad m =>
Bool
-> Name -> m (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
G.getInfo Bool
False) [Name]
names
    let filtered :: [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filtered = forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> a
getTyThing forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a. a -> a
fromNE [Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
mb_stuffs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat (forall a. a -> [a] -> [a]
intersperse (String -> SDoc
text String
"") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((TyThing, Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> (a, b, c, d)
fixInfo) [(TyThing, Fixity, [ClsInst], [FamInst], SDoc)]
filtered)
  where
    getTyThing :: (a, b, c, d, e) -> a
getTyThing (a
t,b
_,c
_,d
_,e
_) = a
t
    fixInfo :: (a, b, c, d, e) -> (a, b, c, d)
fixInfo (a
t,b
f,c
cs,d
fs,e
_) = (a
t,b
f,c
cs,d
fs)

filterOutChildren :: (a -> TyThing) -> [a] -> [a]
filterOutChildren :: forall a. (a -> TyThing) -> [a] -> [a]
filterOutChildren a -> TyThing
get_thing [a]
xs
    = [a
x | a
x <- [a]
xs, Bool -> Bool
not (forall a. NamedThing a => a -> Name
G.getName (a -> TyThing
get_thing a
x) Name -> NameSet -> Bool
`elemNameSet` NameSet
implicits)]
  where
    implicits :: NameSet
implicits = [Name] -> NameSet
mkNameSet [forall a. NamedThing a => a -> Name
G.getName TyThing
t | a
x <- [a]
xs, TyThing
t <- TyThing -> [TyThing]
implicitTyThings (a -> TyThing
get_thing a
x)]

pprInfo :: (TyThing, GHC.Fixity, [InstEnv.ClsInst], [G.FamInst]) -> SDoc
pprInfo :: (TyThing, Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo (TyThing
thing, Fixity
fixity, [ClsInst]
insts, [FamInst]
famInsts)
    = TyThing -> SDoc
pprTyThingInContextLoc TyThing
thing
   SDoc -> SDoc -> SDoc
$$ Fixity -> SDoc
show_fixity Fixity
fixity
   SDoc -> SDoc -> SDoc
$$ [ClsInst] -> SDoc
InstEnv.pprInstances [ClsInst]
insts
   SDoc -> SDoc -> SDoc
$$ [FamInst] -> SDoc
pprFamInsts [FamInst]
famInsts
  where
    show_fixity :: Fixity -> SDoc
show_fixity Fixity
fx
      | Fixity
fx forall a. Eq a => a -> a -> Bool
== Fixity
G.defaultFixity = SDoc
Outputable.empty
      | Bool
otherwise             = forall a. Outputable a => a -> SDoc
ppr Fixity
fx SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> Name
G.getName TyThing
thing)