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

Compatibility with ghc API >= 7.7

Browse Source
This commit is contained in:
Schell Scivally 2013-11-12 15:44:34 -08:00 committed by Kazu Yamamoto
parent 6999d1b0fb
commit b8e20d8e2e
3 changed files with 27 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod/ErrMsg.hs
View File

@ -55,7 +55,7 @@ errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList
ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String
ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext
where where
spn = head (errMsgSpans err) spn = errMsgSpan err
msg = errMsgShortDoc err msg = errMsgShortDoc err
ext = showMsg dflag ls (errMsgExtraInfo err) ext = showMsg dflag ls (errMsgExtraInfo err)

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

@ -258,9 +258,9 @@ infoThing str = do
return $ vcat (intersperse (text "") $ map (pprInfo False) filtered) return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
#if __GLASGOW_HASKELL__ >= 707 #if __GLASGOW_HASKELL__ >= 707
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
pprInfo pefas (thing, fixity, insts, famInsts) pprInfo _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc pefas thing = pprTyThingInContextLoc thing
$$ show_fixity fixity $$ show_fixity fixity
$$ InstEnv.pprInstances insts $$ InstEnv.pprInstances insts
$$ pprFamInsts famInsts $$ pprFamInsts famInsts
@ -279,3 +279,4 @@ pprInfo pefas (thing, fixity, insts)
| fx == defaultFixity = Outputable.empty | fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing) | otherwise = ppr fx <+> ppr (getName thing)
#endif #endif

25
Language/Haskell/GhcMod/Info.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances, CPP #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -65,6 +65,19 @@ info opt cradle file modstr expr =
---------------------------------------------------------------- ----------------------------------------------------------------
#if __GLASGOW_HASKELL__ >= 707
instance HasType (LHsExpr Id) where
getType tcm e = do
hs_env <- getSession
(_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env fi_env e
return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe
where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
tcgEnv = fst $ tm_internals_ tcm
rn_env = tcg_rdr_env tcgEnv
ty_env = tcg_type_env tcgEnv
fi_env = tcg_fam_inst_env tcgEnv
#else
instance HasType (LHsExpr Id) where instance HasType (LHsExpr Id) where
getType tcm e = do getType tcm e = do
hs_env <- getSession hs_env <- getSession
@ -72,8 +85,10 @@ instance HasType (LHsExpr Id) where
return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe
where where
modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm
rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm tcgEnv = fst $ tm_internals_ tcm
ty_env = tcg_type_env $ fst $ tm_internals_ tcm rn_env = tcg_rdr_env tcgEnv
ty_env = tcg_type_env tcgEnv
#endif
instance HasType (LPat Id) where instance HasType (LPat Id) where
getType _ (L spn pat) = return $ Just (spn, hsPatType pat) getType _ (L spn pat) = return $ Just (spn, hsPatType pat)
@ -137,7 +152,11 @@ listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
pretty :: DynFlags -> Type -> String pretty :: DynFlags -> Type -> String
#if __GLASGOW_HASKELL__ >= 707
pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser
#else
pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False
#endif
---------------------------------------------------------------- ----------------------------------------------------------------