d3aacb3 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Clean up UtilGHC (#963)

d3aacb3Neil Mitchell7 years ago

src/Development/IDE/Functions/AtPoint.hs+1

compare with master

unifiedsplit

@@ -11,6 +11,7 @@ module Development.IDE.Functions.AtPoint (

12import Development.IDE.Functions.Documentation

13import Development.IDE.Functions.GHCError

14+import Development.IDE.Orphans()

15-- DAML compiler and infrastructure

16-- DAML compiler and infrastructure

16import Development.IDE.Types.Diagnostics

17import Development.IDE.Types.Diagnostics

src/Development/IDE/Functions/Compile.hs+2−2

@@ -197,7 +197,7 @@ compileModule opt mod packageState uniqSupply deps pkgs tmr =

197 let pm = tm_parsed_module tm

198 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

199 let tm' = tm{tm_parsed_module = pm'}

200− removeTypeableInfo . GHC.dm_core_module <$> GHC.desugarModule tm'

200+ GHC.dm_core_module <$> GHC.desugarModule tm'

201

202 -- give variables unique OccNames

203 (tidy, details) <- liftIO $ tidyProgram session desugar

@@ -479,7 +479,7 @@ parsePragmasIntoDynFlags fp contents = catchSrcErrors $ do

479

480generatePackageState :: [FilePath] -> Bool -> [(String, ModRenaming)] -> IO PackageDynFlags

481generatePackageState paths hideAllPkgs pkgImports = do

482− let dflags = setPackageImports hideAllPkgs pkgImports $ setPackageDbs paths (defaultDynFlags fakeSettings fakeLlvmConfig)

482+ let dflags = setPackageImports hideAllPkgs pkgImports $ setPackageDbs paths fakeDynFlags

483 (newDynFlags, _) <- initPackages dflags

484 pure $ getPackageDynFlags newDynFlags

485

src/Development/IDE/Functions/DependencyInformation.hs+1

@@ -13,6 +13,7 @@ module Development.IDE.Functions.DependencyInformation

14import Control.DeepSeq

15import Data.Bifunctor

16+import Development.IDE.Orphans()

16import Data.Either

17import Data.Either

17import Data.Foldable

18import Data.Foldable

18import Data.Graph

19import Data.Graph

src/Development/IDE/Functions/FindImports.hs+1−1

@@ -10,7 +10,7 @@ module Development.IDE.Functions.FindImports

10 ) where

12import Development.IDE.Functions.GHCError as ErrUtils

13−

13+import Development.IDE.Orphans()

14-- GHC imports

15import BasicTypes (StringLiteral(..))

16import DynFlags

src/Development/IDE/Functions/GHCError.hs+1−1

@@ -30,7 +30,7 @@ module Development.IDE.Functions.GHCError

31import Development.IDE.Types.Diagnostics as D

32import qualified Data.Text as T

33−import Development.IDE.UtilGHC()

33+import Development.IDE.Orphans()

34import qualified FastString as FS

35import GHC

36import Bag

src/Development/IDE/Orphans.hsnew file+48

@@ -0,0 +1,48 @@

2+-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# OPTIONS_GHC -Wno-orphans #-}

7+-- | Orphan instances for GHC.

8+-- Note that the 'NFData' instances may not be law abiding.

9+module Development.IDE.Orphans() where

10+

11+import GHC hiding (convertLit)

12+import GhcPlugins as GHC hiding (fst3, (<>))

13+import qualified StringBuffer as SB

14+import Control.DeepSeq

15+import Development.IDE.UtilGHC

16+

17+

18+-- Orphan instances for types from the GHC API.

19+instance Show CoreModule where show = prettyPrint

20+instance NFData CoreModule where rnf = rwhnf

21+

22+

23+instance Show InstalledUnitId where

24+ show = installedUnitIdString

25+

26+instance NFData InstalledUnitId where rnf = rwhnf

27+

28+instance NFData SB.StringBuffer where rnf = rwhnf

29+

30+instance Show Module where

31+ show = moduleNameString . moduleName

32+

33+instance Show RdrName where show = prettyPrint

34+instance Show ComponentId where show = prettyPrint

35+instance Show SourcePackageId where show = prettyPrint

36+instance Show ModuleName where show = prettyPrint

37+instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

38+instance Show PackageName where show = prettyPrint

39+instance Show PackageState where show _ = "PackageState"

40+instance Show Name where show = prettyPrint

41+

42+

43+-- Things which are defined in this module, but still orphan since I need

44+-- the definitions in this module

45+

46+deriving instance Show PackageDynFlags

47+instance NFData PackageDynFlags where

48+ rnf (PackageDynFlags db state insts) = db `seq` state `seq` rnf insts

src/Development/IDE/State/FileStore.hs+1−2

@@ -12,7 +12,7 @@ module Development.IDE.State.FileStore(

14import StringBuffer

15−import Development.IDE.UtilGHC()

15+import Development.IDE.Orphans()

17import qualified Data.Map.Strict as Map

18import qualified Data.Text as T

@@ -150,5 +150,4 @@ setBufferModified state absFile (mcontents, !time) = do

150

151-- would be nice to do this more efficiently...

152textToStringBuffer :: T.Text -> SB.StringBuffer

153−-- would be nice to do this more efficiently...

154textToStringBuffer = SB.stringToStringBuffer . T.unpack

153textToStringBuffer = SB.stringToStringBuffer . T.unpack

src/Development/IDE/State/Rules.hs+13−13

@@ -33,7 +33,6 @@ import Development.IDE.Functions.DependencyInformation

33import Development.IDE.Functions.FindImports

34import Development.IDE.State.FileStore

35import Development.IDE.Types.Diagnostics as Base

36−import Development.IDE.UtilGHC

37import Data.Bifunctor

36import Data.Bifunctor

38import Data.Either.Extra

37import Data.Either.Extra

39import Data.Maybe

38import Data.Maybe

@@ -88,6 +87,19 @@ getUniqSupplyFrom Env{..} =

88getGhcCore :: FilePath -> Action (Maybe [CoreModule])

87getGhcCore :: FilePath -> Action (Maybe [CoreModule])

89getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)

88getGhcCore file = eitherToMaybe <$> runExceptT (coresForFile file)

90+-- | Generate the GHC Core for the supplied file and its dependencies.

91+coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]

92+coresForFile file = do

93+ files <- transitiveModuleDeps <$> useE GetDependencies file

94+ pms <- usesE GetParsedModule $ files ++ [file]

95+ fs <- liftIO

96+ . mapM fileFromParsedModule

97+ $ pms

98+ cores <- usesE GenerateCore fs

99+ pure (map Compile.gmCore cores)

100+

101+

102+

91-- | Get all transitive file dependencies of a given module.

103-- | Get all transitive file dependencies of a given module.

92-- Does not include the file itself.

104-- Does not include the file itself.

93getDependencies :: FilePath -> Action (Maybe [FilePath])

105getDependencies :: FilePath -> Action (Maybe [FilePath])

@@ -125,18 +137,6 @@ usesE

125 => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]

137 => k -> [FilePath] -> ExceptT [FileDiagnostic] Action [v]

126usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k

138usesE k = ExceptT . fmap (mapM toIdeResultSilent) . uses k

127

139

128−-- | Generate the GHC Core for the supplied file and its dependencies.

129−coresForFile :: FilePath -> ExceptT [FileDiagnostic] Action [CoreModule]

130−coresForFile file = do

131− files <- transitiveModuleDeps <$> useE GetDependencies file

132− pms <- usesE GetParsedModule $ files ++ [file]

133− fs <- liftIO

134− . mapM fileFromParsedModule

135− . filter (not . modIsInternal . ms_mod . pm_mod_summary)

136− $ pms

137− cores <- usesE GenerateCore fs

138− pure (map Compile.gmCore cores)

139−

140-- | Try to get hover text for the name under point.

141getAtPointForFile

142 :: FilePath

src/Development/IDE/UtilGHC.hs+23−114

@@ -1,10 +1,7 @@

2-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE PatternSynonyms #-}

6{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

4{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

7−{-# OPTIONS_GHC -Wno-orphans #-}

9-- | GHC utility functions. Importantly, code using our GHC should never:

6-- | GHC utility functions. Importantly, code using our GHC should never:

10--

7--

@@ -14,18 +11,11 @@

14module Development.IDE.UtilGHC(

11module Development.IDE.UtilGHC(

15 PackageDynFlags(..), setPackageDynFlags, getPackageDynFlags,

12 PackageDynFlags(..), setPackageDynFlags, getPackageDynFlags,

16 modifyDynFlags,

13 modifyDynFlags,

17− removeTypeableInfo,

18 setPackageImports,

14 setPackageImports,

19 setPackageDbs,

15 setPackageDbs,

20− fakeSettings,

16+ fakeDynFlags,

21− fakeLlvmConfig,

22 prettyPrint,

17 prettyPrint,

23− importGenerated,

24− mkImport,

25− runGhcFast,

18+ runGhcFast

26− setImports,

27− setThisInstalledUnitId,

28− modIsInternal

29 ) where

19 ) where

31import Config

21import Config

@@ -37,12 +27,8 @@ import HscMain

37import qualified Packages

27import qualified Packages

38import Platform

28import Platform

39import qualified EnumSet

29import qualified EnumSet

40−

41−import Control.DeepSeq

42import Data.IORef

30import Data.IORef

43−import Data.List

44import GHC.Generics (Generic)

31import GHC.Generics (Generic)

45−import qualified StringBuffer as SB

47----------------------------------------------------------------------

33----------------------------------------------------------------------

48-- GHC setup

34-- GHC setup

@@ -84,10 +70,7 @@ data PackageDynFlags = PackageDynFlags

84 { pdfPkgDatabase :: !(Maybe [(FilePath, [Packages.PackageConfig])])

70 { pdfPkgDatabase :: !(Maybe [(FilePath, [Packages.PackageConfig])])

85 , pdfPkgState :: !Packages.PackageState

71 , pdfPkgState :: !Packages.PackageState

86 , pdfThisUnitIdInsts :: !(Maybe [(ModuleName, Module)])

72 , pdfThisUnitIdInsts :: !(Maybe [(ModuleName, Module)])

87− } deriving (Generic, Show)

73+ } deriving (Generic)

88−

89−instance NFData PackageDynFlags where

90− rnf (PackageDynFlags db state insts) = db `seq` state `seq` rnf insts

92setPackageDynFlags :: PackageDynFlags -> DynFlags -> DynFlags

75setPackageDynFlags :: PackageDynFlags -> DynFlags -> DynFlags

93setPackageDynFlags PackageDynFlags{..} dflags = dflags

76setPackageDynFlags PackageDynFlags{..} dflags = dflags

@@ -104,48 +87,8 @@ getPackageDynFlags DynFlags{..} = PackageDynFlags

104 }

87 }

105

106

107−-- | A version of `showSDoc` that uses default flags (to avoid uses of

108−-- `showSDocUnsafe`).

109−showSDocDefault :: SDoc -> String

110−showSDocDefault = showSDoc dynFlags

111− where dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig

112−

113prettyPrint :: Outputable a => a -> String

90prettyPrint :: Outputable a => a -> String

114−prettyPrint = showSDocDefault . ppr

91+prettyPrint = showSDoc fakeDynFlags . ppr

115−

116−-- FIXME(#1203): This must move out of `haskell-ide-core` and into `damlc`.

117−internalModules :: [String]

118−internalModules =

119− [ "Data.String"

120− , "GHC.CString"

121− , "GHC.Integer.Type"

122− , "GHC.Natural"

123− , "GHC.Real"

124− , "GHC.Types"

125− ]

126−

127−-- | Checks if a given module is internal, i.e. gets removed in the Core->LF

128−-- translation. TODO where should this live?

129−modIsInternal :: Module -> Bool

130−modIsInternal m = moduleNameString (moduleName m) `elem` internalModules

131− -- TODO should we consider DA.Internal.* internal? Difference to GHC.*

132− -- modules is that these do not disappear in the LF conversion.

133−

134−-- | This import was generated, not user written, so should not produce unused import warnings

135−importGenerated :: Bool -> ImportDecl phase -> ImportDecl phase

136−importGenerated qual i = i{ideclImplicit=True, ideclQualified=qual}

137−

138−mkImport :: Located ModuleName -> ImportDecl GhcPs

139−mkImport mname = GHC.ImportDecl GHC.NoExt GHC.NoSourceText mname Nothing False False False False Nothing Nothing

140−

141−-- FIXME(#1203): This needs to move out of haskell-ide-core.

142−removeTypeableInfo :: ModGuts -> ModGuts

143−removeTypeableInfo guts =

144− guts{mg_binds = filter (not . isTypeableInfo) (mg_binds guts)}

145− where

146− isTypeableInfo = \case

147− NonRec name _ -> any (`isPrefixOf` getOccString name) ["$krep", "$tc", "$trModule"]

148− Rec _ -> False

149

150-- | Like 'runGhc' but much faster (400x), with less IO and no file dependency

93-- | Like 'runGhc' but much faster (400x), with less IO and no file dependency

151runGhcFast :: Ghc a -> IO a

94runGhcFast :: Ghc a -> IO a

@@ -154,61 +97,27 @@ runGhcFast act = do

154 ref <- newIORef (error "empty session")

97 ref <- newIORef (error "empty session")

155 let session = Session ref

98 let session = Session ref

156 flip unGhc session $ do

99 flip unGhc session $ do

157− dflags <- liftIO $ initDynFlags $ defaultDynFlags fakeSettings fakeLlvmConfig

100+ dflags <- liftIO $ initDynFlags fakeDynFlags

158 liftIO $ setUnsafeGlobalDynFlags dflags

101 liftIO $ setUnsafeGlobalDynFlags dflags

159 env <- liftIO $ newHscEnv dflags

102 env <- liftIO $ newHscEnv dflags

160 setSession env

103 setSession env

161 withCleanupSession act

104 withCleanupSession act

162

105

163−-- These settings are mostly undefined, but define just enough for what we want to do (which isn't code gen)

106+-- Fake DynFlags which are mostly undefined, but define enough to do a little bit

164−fakeSettings :: Settings

107+fakeDynFlags :: DynFlags

108+fakeDynFlags = defaultDynFlags settings ([], [])

109+ where

165−fakeSettings = Settings

110+ settings = Settings

166− {sTargetPlatform=platform

111+ {sTargetPlatform = Platform

167− ,sPlatformConstants=platformConstants

112+ {platformWordSize = 8

168− ,sProjectVersion=cProjectVersion

113+ ,platformOS = OSUnknown

169− ,sProgramName="ghc"

170− ,sOpt_P_fingerprint=fingerprint0

171− }

172− where

173− platform = Platform{platformWordSize=8, platformOS=OSUnknown, platformUnregisterised=True}

114+ ,platformUnregisterised = True

115+ }

116+ ,sPlatformConstants = PlatformConstants

174− platformConstants = PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}

117+ {pc_DYNAMIC_BY_DEFAULT = False

175−

118+ ,pc_WORD_SIZE = 8

176−fakeLlvmConfig :: (LlvmTargets, LlvmPasses)

119+ }

177−fakeLlvmConfig = ([], [])

120+ ,sProjectVersion = cProjectVersion

178−

121+ ,sProgramName = "ghc"

179−

122+ ,sOpt_P_fingerprint = fingerprint0

180−setThisInstalledUnitId :: UnitId -> DynFlags -> DynFlags

123+ }

181−setThisInstalledUnitId unitId dflags =

182− dflags {thisInstalledUnitId = toInstalledUnitId unitId}

183−

184−setImports :: [FilePath] -> DynFlags -> DynFlags

185−setImports paths dflags = dflags { importPaths = paths }

186−

187−

188−

189−-- Orphan instances for types from the GHC API.

190−instance Show CoreModule where show = prettyPrint

191−instance NFData CoreModule where rnf !_ = ()

192−

193−instance Show RdrName where show = prettyPrint

194−instance NFData RdrName where rnf !_ = ()

195−

196−instance Show InstalledUnitId where

197− show = installedUnitIdString

198−

199−instance NFData InstalledUnitId where

200− rnf = rwhnf

201−

202−instance NFData SB.StringBuffer where

203− rnf = rwhnf

204−

205−instance Show Module where

206− show = moduleNameString . moduleName

207−

208−instance Show ComponentId where show = prettyPrint

209−instance Show SourcePackageId where show = prettyPrint

210−instance Show ModuleName where show = prettyPrint

211−instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

212−instance Show PackageName where show = prettyPrint

213−instance Show Packages.PackageState where show _ = "PackageState"

214−instance Show Name where show = prettyPrint