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

Porting ghc-mod to GHC 7.7

Browse Source
This commit is contained in:
Daniil Frumin 2013-06-28 00:25:22 +04:00
parent b38649b1dc
commit 54d6f5f690
2 changed files with 40 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Language/Haskell/GhcMod/GHCApi.hs
View File

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

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

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