git.iko.soy/ghcide
on b9dfd49 help sign in
ghcide/src/Development/IDE/UtilGHC.hs
215 lines 7.6 kB history raw
1-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE PatternSynonyms #-}
6{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
7{-# OPTIONS_GHC -Wno-orphans #-}
9-- | GHC utility functions. Importantly, code using our GHC should never:
10--
11-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.
12--
13-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.
14module Development.IDE.UtilGHC(
15 PackageState(..),
16 modifyDynFlags,
17 textToStringBuffer,
18 removeTypeableInfo,
19 setPackageImports,
20 setPackageDbs,
21 fakeSettings,
22 fakeLlvmConfig,
23 prettyPrint,
24 importGenerated,
25 mkImport,
26 runGhcFast,
27 setImports,
28 setPackageState,
29 setThisInstalledUnitId,
30 modIsInternal
31 ) where
33import Config
34import Fingerprint
35import GHC hiding (convertLit)
36import GhcMonad
37import GhcPlugins as GHC hiding (PackageState, fst3, (<>))
38import HscMain
39import qualified Packages
40import Platform
41import qualified StringBuffer as SB
42import qualified EnumSet
44import Control.DeepSeq
45import Data.IORef
46import Data.List
47import qualified Data.Text as T
48import GHC.Generics (Generic)
50----------------------------------------------------------------------
51-- GHC setup
53setPackageDbs :: [FilePath] -> DynFlags -> DynFlags
54setPackageDbs paths dflags =
55 dflags
56 { packageDBFlags =
57 [PackageDB $ PkgConfFile path | path <- paths] ++ [NoGlobalPackageDB, ClearPackageDBs]
58 , pkgDatabase = if null paths then Just [] else Nothing
59 -- if we don't load any packages set the package database to empty and loaded.
60 , settings = (settings dflags)
61 {sTopDir = case paths of p:_ -> p; _ -> error "No package db path available but used $topdir"
62 , sSystemPackageConfig = case paths of p:_ -> p; _ -> error "No package db path available but used system package config"
63 }
64 }
66setPackageImports :: Bool -> [(String, ModRenaming)] -> DynFlags -> DynFlags
67setPackageImports hideAllPkgs pkgImports dflags = dflags {
68 packageFlags = packageFlags dflags ++
69 [ExposePackage pkgName (UnitIdArg $ stringToUnitId pkgName) renaming
70 | (pkgName, renaming) <- pkgImports
71 ]
72 , generalFlags = if hideAllPkgs
73 then Opt_HideAllPackages `EnumSet.insert` generalFlags dflags
74 else generalFlags dflags
75 }
77modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
78modifyDynFlags f = do
79 newFlags <- f <$> getSessionDynFlags
80 -- We do not use setSessionDynFlags here since we handle package
81 -- initialization separately.
82 modifySession $ \h ->
83 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
85-- | This is the subset of `DynFlags` that is computed by package initialization.
86data PackageState = PackageState
87 { pkgStateDb :: !(Maybe [(FilePath, [Packages.PackageConfig])])
88 , pkgStateState :: !Packages.PackageState
89 , pkgThisUnitIdInsts :: !(Maybe [(ModuleName, Module)])
90 } deriving (Generic, Show)
92instance NFData PackageState where
93 rnf (PackageState db state insts) = db `seq` state `seq` rnf insts
96-- | A version of `showSDoc` that uses default flags (to avoid uses of
97-- `showSDocUnsafe`).
98showSDocDefault :: SDoc -> String
99showSDocDefault = showSDoc dynFlags
100 where dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
102prettyPrint :: Outputable a => a -> String
103prettyPrint = showSDocDefault . ppr
105textToStringBuffer :: T.Text -> SB.StringBuffer
106-- would be nice to do this more efficiently...
107textToStringBuffer = SB.stringToStringBuffer . T.unpack
109-- FIXME(#1203): This must move out of `haskell-ide-core` and into `damlc`.
110internalModules :: [String]
111internalModules =
112 [ "Data.String"
113 , "GHC.CString"
114 , "GHC.Integer.Type"
115 , "GHC.Natural"
116 , "GHC.Real"
117 , "GHC.Types"
118 ]
120-- | Checks if a given module is internal, i.e. gets removed in the Core->LF
121-- translation. TODO where should this live?
122modIsInternal :: Module -> Bool
123modIsInternal m = moduleNameString (moduleName m) `elem` internalModules
124 -- TODO should we consider DA.Internal.* internal? Difference to GHC.*
125 -- modules is that these do not disappear in the LF conversion.
127-- | This import was generated, not user written, so should not produce unused import warnings
128importGenerated :: Bool -> ImportDecl phase -> ImportDecl phase
129importGenerated qual i = i{ideclImplicit=True, ideclQualified=qual}
131mkImport :: Located ModuleName -> ImportDecl GhcPs
132mkImport mname = GHC.ImportDecl GHC.NoExt GHC.NoSourceText mname Nothing False False False False Nothing Nothing
134-- FIXME(#1203): This needs to move out of haskell-ide-core.
135removeTypeableInfo :: ModGuts -> ModGuts
136removeTypeableInfo guts =
137 guts{mg_binds = filter (not . isTypeableInfo) (mg_binds guts)}
138 where
139 isTypeableInfo = \case
140 NonRec name _ -> any (`isPrefixOf` getOccString name) ["$krep", "$tc", "$trModule"]
141 Rec _ -> False
143-- | Like 'runGhc' but much faster (400x), with less IO and no file dependency
144runGhcFast :: Ghc a -> IO a
145-- copied from GHC with the nasty bits dropped
146runGhcFast act = do
147 ref <- newIORef (error "empty session")
148 let session = Session ref
149 flip unGhc session $ do
150 dflags <- liftIO $ initDynFlags $ defaultDynFlags fakeSettings fakeLlvmConfig
151 liftIO $ setUnsafeGlobalDynFlags dflags
152 env <- liftIO $ newHscEnv dflags
153 setSession env
154 withCleanupSession act
156-- These settings are mostly undefined, but define just enough for what we want to do (which isn't code gen)
157fakeSettings :: Settings
158fakeSettings = Settings
159 {sTargetPlatform=platform
160 ,sPlatformConstants=platformConstants
161 ,sProjectVersion=cProjectVersion
162 ,sProgramName="ghc"
163 ,sOpt_P_fingerprint=fingerprint0
164 }
165 where
166 platform = Platform{platformWordSize=8, platformOS=OSUnknown, platformUnregisterised=True}
167 platformConstants = PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}
169fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
170fakeLlvmConfig = ([], [])
173setThisInstalledUnitId :: UnitId -> DynFlags -> DynFlags
174setThisInstalledUnitId unitId dflags =
175 dflags {thisInstalledUnitId = toInstalledUnitId unitId}
177setImports :: [FilePath] -> DynFlags -> DynFlags
178setImports paths dflags = dflags { importPaths = paths }
180setPackageState :: PackageState -> DynFlags -> DynFlags
181setPackageState state dflags =
182 dflags
183 { pkgDatabase = pkgStateDb state
184 , pkgState = pkgStateState state
185 , thisUnitIdInsts_ = pkgThisUnitIdInsts state
186 }
190-- Orphan instances for types from the GHC API.
191instance Show CoreModule where show = prettyPrint
192instance NFData CoreModule where rnf !_ = ()
194instance Show RdrName where show = prettyPrint
195instance NFData RdrName where rnf !_ = ()
197instance Show InstalledUnitId where
198 show = installedUnitIdString
200instance NFData InstalledUnitId where
201 rnf = rwhnf
203instance NFData SB.StringBuffer where
204 rnf = rwhnf
206instance Show Module where
207 show = moduleNameString . moduleName
209instance Show ComponentId where show = prettyPrint
210instance Show SourcePackageId where show = prettyPrint
211instance Show ModuleName where show = prettyPrint
212instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
213instance Show PackageName where show = prettyPrint
214instance Show Packages.PackageState where show _ = "PackageState"
215instance Show Name where show = prettyPrint