Fix mapping subst in info for insts add type fams
This commit is contained in:
parent
89bc149f60
commit
11a1ad2cf3
@ -75,6 +75,10 @@ import qualified InstEnv
|
||||
import qualified Pretty
|
||||
import qualified StringBuffer as SB
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
import CoAxiom (coAxiomTyCon)
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
import FamInstEnv
|
||||
import ConLike (ConLike(..))
|
||||
@ -357,28 +361,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F
|
||||
pprInfo m _ (thing, fixity, insts, famInsts)
|
||||
= pprTyThingInContextLoc' thing
|
||||
$$ show_fixity fixity
|
||||
$$ InstEnv.pprInstances insts
|
||||
$$ pprFamInsts famInsts
|
||||
$$ vcat (map pprInstance' insts)
|
||||
$$ vcat (map pprFamInst' famInsts)
|
||||
#else
|
||||
pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
|
||||
pprInfo m pefas (thing, fixity, insts)
|
||||
= pprTyThingInContextLoc' pefas thing
|
||||
$$ show_fixity fixity
|
||||
$$ vcat (map pprInstance insts)
|
||||
$$ vcat (map pprInstance' insts)
|
||||
#endif
|
||||
where
|
||||
show_fixity fx
|
||||
| fx == defaultFixity = Outputable.empty
|
||||
| otherwise = ppr fx <+> ppr (getName thing)
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2
|
||||
(char '\t' <> ptext (sLit "--") <+> loc)
|
||||
where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
|
||||
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
|
||||
= pprTyThingInContextLoc (ATyCon rep_tc)
|
||||
|
||||
pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
|
||||
, fi_tys = lhs_tys, fi_rhs = rhs })
|
||||
= showWithLoc (pprDefinedAt' (getName axiom)) $
|
||||
hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
|
||||
2 (equals <+> ppr rhs)
|
||||
#else
|
||||
pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2
|
||||
(char '\t' <> ptext (sLit "--") <+> loc)
|
||||
where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
|
||||
pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
|
||||
#endif
|
||||
#else
|
||||
pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
|
||||
#endif
|
||||
showWithLoc loc doc
|
||||
= hang doc 2 (char '\t' <> comment <+> loc)
|
||||
-- The tab tries to make them line up a bit
|
||||
where
|
||||
comment = ptext (sLit "--")
|
||||
pprInstance' ispec = hang (pprInstanceHdr ispec)
|
||||
2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
|
||||
pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
|
||||
pprNameDefnLoc' name
|
||||
= case Name.nameSrcLoc name of
|
||||
RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
|
||||
|
Loading…
Reference in New Issue
Block a user