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)