hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #769 from atom-haskell/fix-file-map-insts-type-fams

Browse Source 
Fix mapping subst in info for insts add type fams
This commit is contained in:
Nikolay Yakimov 2016-03-15 23:18:12 +03:00
commit c925e920a0
1 changed files with 29 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
Language/Haskell/GhcMod/Gap.hs
View File

@ -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)