diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index 2d465d2..6026777 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.GHCApi ( withGHC @@ -112,7 +113,11 @@ modifyFlags d0 idirs mDepPkgs splice build | otherwise = d3 setCabalPkg :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 707 +setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage +#else setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage +#endif setSplice :: DynFlags -> DynFlags setSplice dflag = dopt_set dflag Opt_D_dump_splices @@ -120,7 +125,11 @@ setSplice dflag = dopt_set dflag Opt_D_dump_splices addDevPkgs :: DynFlags -> [Package] -> DynFlags addDevPkgs df pkgs = df'' where +#if __GLASGOW_HASKELL__ >= 707 + df' = gopt_set df Opt_HideAllPackages +#else df' = dopt_set df Opt_HideAllPackages +#endif df'' = df' { packageFlags = map ExposePackage pkgs ++ packageFlags df } diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 484196e..a1587ef 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, CPP #-} module Language.Haskell.GhcMod.Info ( infoExpr @@ -18,9 +18,15 @@ import Data.Maybe import Data.Ord as O import Data.Time.Clock import Desugar +#if __GLASGOW_HASKELL__ >= 707 +import FamInstEnv +#endif import GHC import GHC.SYB.Utils import HscTypes +#if __GLASGOW_HASKELL__ >= 707 +import InstEnv +#endif import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCChoice @@ -31,6 +37,7 @@ import Outputable import PprTyThing import TcHsSyn (hsPatType) import TcRnTypes +import TcType ---------------------------------------------------------------- @@ -75,7 +82,12 @@ instance HasType (LHsExpr Id) where ty_env = tcg_type_env $ fst $ tm_internals_ tcm instance HasType (LHsBind Id) where +#if __GLASGOW_HASKELL__ >= 707 + getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ) + where typ = mkFunTys in_tys out_typ +#else getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) +#endif getType _ _ = return Nothing instance HasType (LPat Id) where @@ -148,8 +160,13 @@ pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False infoThing :: String -> Ghc String infoThing str = do names <- parseName str +#if __GLASGOW_HASKELL__ >= 707 + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) +#else mb_stuffs <- mapM getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) +#endif dflag <- getSessionDynFlags return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered) @@ -159,6 +176,18 @@ filterOutChildren get_thing xs where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] +#if __GLASGOW_HASKELL__ >= 707 +pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc +pprInfo pefas (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc pefas thing + $$ show_fixity fixity + $$ pprInstances insts + $$ pprFamInsts famInsts + where + show_fixity fx + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) +#else pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc pprInfo pefas (thing, fixity, insts) = pprTyThingInContextLoc pefas thing @@ -168,7 +197,7 @@ pprInfo pefas (thing, fixity, insts) show_fixity fx | fx == defaultFixity = Outputable.empty | otherwise = ppr fx <+> ppr (getName thing) - +#endif ---------------------------------------------------------------- inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String