git.iko.soy/ghcide
on fffd3dd help sign in
ghcide/src/Development/IDE/UtilGHC.hs
319 lines 12 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 where
16import "ghc-lib-parser" Config
17import qualified "ghc-lib-parser" CmdLineParser as Cmd (warnMsg)
18import "ghc-lib-parser" DynFlags (parseDynamicFilePragma)
19import "ghc-lib-parser" Fingerprint
20import "ghc-lib" GHC hiding (convertLit)
21import "ghc-lib-parser" GHC.LanguageExtensions.Type
22import "ghc-lib-parser" GhcMonad
23import "ghc-lib" GhcPlugins as GHC hiding (PackageState, fst3, (<>))
24import "ghc-lib" HscMain
25import qualified "ghc-lib-parser" Packages
26import "ghc-lib-parser" Panic (throwGhcExceptionIO)
27import "ghc-lib-parser" Platform
28import qualified "ghc-lib-parser" StringBuffer as SB
29import qualified "ghc-lib-parser" EnumSet
31import Control.DeepSeq
32import Control.Monad
33import Data.IORef
34import Data.List
35import qualified Data.Text as T
36import GHC.Generics (Generic)
38----------------------------------------------------------------------
39-- GHC setup
41-- | Language options enabled in the DAML-1.2 compilation
42xExtensionsSet :: [Extension]
43xExtensionsSet =
44 [ -- syntactic convenience
45 RecordPuns, RecordWildCards, LambdaCase, TupleSections, BlockArguments, ViewPatterns,
46 NumericUnderscores
47 -- records
48 , DuplicateRecordFields, DisambiguateRecordFields
49 -- types and kinds
50 , ScopedTypeVariables, ExplicitForAll
51 , DataKinds, KindSignatures, RankNTypes, TypeApplications
52 , ConstraintKinds
53 -- type classes
54 , MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeSynonymInstances
55 , DefaultSignatures, StandaloneDeriving, FunctionalDependencies, DeriveFunctor
56 -- replacing primitives
57 , RebindableSyntax, OverloadedStrings
58 -- strictness
59 , Strict, StrictData
60 -- avoiding letrec in list comp (see DEL-3841)
61 , MonadComprehensions
62 -- package imports
63 , PackageImports
64 -- our changes
65 , NewColonConvention
66 , DamlVersionRequired
67 , WithRecordSyntax
68 , DamlTemplate
69 ]
72-- | Language settings _disabled_ ($-XNo...$) in the DAML-1.2 compilation
73xExtensionsUnset :: [Extension]
74xExtensionsUnset = [ ]
76-- | Flags set for DAML-1.2 compilation
77xFlagsSet :: [ GeneralFlag ]
78xFlagsSet = [
79 Opt_Haddock
80 , Opt_Ticky
81 ]
83-- | Warning options set for DAML compilation. Note that these can be modified
84-- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and
85-- '{-# OPTIONS -no-warn-... #-}'.
86wOptsSet :: [ WarningFlag ]
87wOptsSet =
88 [ Opt_WarnUnusedImports
89--, Opt_WarnPrepositiveQualifiedModule
90 , Opt_WarnOverlappingPatterns
91 , Opt_WarnIncompletePatterns
92 ]
94-- | Warning options set for DAML compilation, which become errors.
95wOptsSetFatal :: [ WarningFlag ]
96wOptsSetFatal =
97 [ Opt_WarnMissingFields
98 ]
100-- | Warning options unset for DAML compilation. Note that these can be modified
101-- (per file) by the user via file headers '{-# OPTIONS -fwarn-... #-} and
102-- '{-# OPTIONS -no-warn-... #-}'.
103wOptsUnset :: [ WarningFlag ]
104wOptsUnset =
105 [ Opt_WarnMissingMonadFailInstances -- failable pattern plus RebindableSyntax raises this error
106 , Opt_WarnOverflowedLiterals -- this does not play well with -ticky and the error message is misleading
107 ]
110adjustDynFlags :: [FilePath] -> PackageState -> Maybe String -> DynFlags -> DynFlags
111adjustDynFlags paths packageState mbPackageName dflags
112 = setImports paths
113 $ setPackageState packageState
114 $ setThisInstalledUnitId (maybe mainUnitId stringToUnitId mbPackageName)
115 -- once we have package imports working, we want to import the base package and set this to
116 -- the default instead of always compiling in the context of ghc-prim.
117 $ apply wopt_set wOptsSet
118 $ apply wopt_unset wOptsUnset
119 $ apply wopt_set_fatal wOptsSetFatal
120 $ apply xopt_set xExtensionsSet
121 $ apply xopt_unset xExtensionsUnset
122 $ apply gopt_set xFlagsSet
123 dflags{
124 mainModIs = mkModule primUnitId (mkModuleName "NotAnExistingName"), -- avoid DEL-6770
125 debugLevel = 1,
126 ghcLink = NoLink, hscTarget = HscNothing -- avoid generating .o or .hi files
127 {-, dumpFlags = Opt_D_ppr_debug `EnumSet.insert` dumpFlags dflags -- turn on debug output from GHC-}
128 }
129 where apply f xs d = foldl' f d xs
131setThisInstalledUnitId :: UnitId -> DynFlags -> DynFlags
132setThisInstalledUnitId unitId dflags =
133 dflags {thisInstalledUnitId = toInstalledUnitId unitId}
135setImports :: [FilePath] -> DynFlags -> DynFlags
136setImports paths dflags = dflags { importPaths = paths }
138setPackageState :: PackageState -> DynFlags -> DynFlags
139setPackageState state dflags =
140 dflags
141 { pkgDatabase = pkgStateDb state
142 , pkgState = pkgStateState state
143 , thisUnitIdInsts_ = pkgThisUnitIdInsts state
144 }
146setPackageDbs :: [FilePath] -> DynFlags -> DynFlags
147setPackageDbs paths dflags =
148 dflags
149 { packageDBFlags =
150 [PackageDB $ PkgConfFile path | path <- paths] ++ [NoGlobalPackageDB, ClearPackageDBs]
151 , pkgDatabase = if null paths then Just [] else Nothing
152 -- if we don't load any packages set the package database to empty and loaded.
153 , settings = (settings dflags)
154 {sTopDir = case paths of p:_ -> p; _ -> error "No package db path available but used $topdir"
155 , sSystemPackageConfig = case paths of p:_ -> p; _ -> error "No package db path available but used system package config"
156 }
157 }
159setPackageImports :: Bool -> [(String, [(String, String)])] -> DynFlags -> DynFlags
160setPackageImports hideAllPkgs pkgImports dflags = dflags {
161 packageFlags = packageFlags dflags ++
162 [ExposePackage pkgName (UnitIdArg $ stringToUnitId pkgName)
163 (ModRenaming False [(mkModuleName mod, mkModuleName alias) | (mod, alias) <- aliases])
164 | (pkgName, aliases) <- pkgImports
165 ]
166 , generalFlags = if hideAllPkgs
167 then Opt_HideAllPackages `EnumSet.insert` generalFlags dflags
168 else generalFlags dflags
169 }
171modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
172modifyDynFlags f = do
173 newFlags <- f <$> getSessionDynFlags
174 -- We do not use setSessionDynFlags here since we handle package
175 -- initialization separately.
176 modifySession $ \h ->
177 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
179-- | This is the subset of `DynFlags` that is computed by package initialization.
180data PackageState = PackageState
181 { pkgStateDb :: !(Maybe [(FilePath, [Packages.PackageConfig])])
182 , pkgStateState :: !Packages.PackageState
183 , pkgThisUnitIdInsts :: !(Maybe [(ModuleName, Module)])
184 } deriving (Generic, Show)
186instance NFData PackageState where
187 rnf (PackageState db state insts) = db `seq` state `seq` rnf insts
189-- | Configures the @DynFlags@ for this session to DAML-1.2
190-- compilation:
191-- * Installs a custom log action;
192-- * Sets up the package databases;
193-- * Sets the import paths to the given list of 'FilePath'.
194-- * if present, parses and applies custom options for GHC
195-- (may fail if the custom options are inconsistent with std DAML ones)
196setupDamlGHC :: GhcMonad m => [FilePath] -> Maybe String -> PackageState -> [String] -> m ()
197setupDamlGHC importPaths mbPackageName packageState [] =
198 modifyDynFlags $ adjustDynFlags importPaths packageState mbPackageName
199-- if custom options are given, add them after the standard DAML flag setup
200setupDamlGHC importPaths mbPackageName packageState customOpts = do
201 setupDamlGHC importPaths mbPackageName packageState []
202 damlDFlags <- getSessionDynFlags
203 (dflags', leftover, warns) <- parseDynamicFilePragma damlDFlags $ map noLoc customOpts
205 let leftoverError = CmdLineError $
206 (unlines . ("Unable to parse custom flags:":) . map unLoc) leftover
207 unless (null leftover) $ liftIO $ throwGhcExceptionIO leftoverError
209 unless (null warns) $
210 liftIO $ putStrLn $ unlines $ "Warnings:" : map (unLoc . Cmd.warnMsg) warns
212 modifySession $ \h ->
213 h { hsc_dflags = dflags', hsc_IC = (hsc_IC h) {ic_dflags = dflags' } }
215-- | A version of `showSDoc` that uses default flags (to avoid uses of
216-- `showSDocUnsafe`).
217showSDocDefault :: SDoc -> String
218showSDocDefault = showSDoc dynFlags
219 where dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
221prettyPrint :: Outputable a => a -> String
222prettyPrint = showSDocDefault . ppr
224textToStringBuffer :: T.Text -> SB.StringBuffer
225-- would be nice to do this more efficiently...
226textToStringBuffer = SB.stringToStringBuffer . T.unpack
228-- FIXME(#1203): This must move out of `haskell-ide-core` and into `damlc`.
229internalModules :: [String]
230internalModules =
231 [ "Data.String"
232 , "GHC.CString"
233 , "GHC.Integer.Type"
234 , "GHC.Natural"
235 , "GHC.Real"
236 , "GHC.Types"
237 ]
239-- | Checks if a given module is internal, i.e. gets removed in the Core->LF
240-- translation. TODO where should this live?
241modIsInternal :: Module -> Bool
242modIsInternal m = moduleNameString (moduleName m) `elem` internalModules
243 -- TODO should we consider DA.Internal.* internal? Difference to GHC.*
244 -- modules is that these do not disappear in the LF conversion.
246-- | This import was generated, not user written, so should not produce unused import warnings
247importGenerated :: Bool -> ImportDecl phase -> ImportDecl phase
248importGenerated qual i = i{ideclImplicit=True, ideclQualified=qual}
250mkImport :: Located ModuleName -> ImportDecl GhcPs
251mkImport mname = GHC.ImportDecl GHC.NoExt GHC.NoSourceText mname Nothing False False False False Nothing Nothing
253-- FIXME(#1203): This needs to move out of haskell-ide-core.
254removeTypeableInfo :: ModGuts -> ModGuts
255removeTypeableInfo guts =
256 guts{mg_binds = filter (not . isTypeableInfo) (mg_binds guts)}
257 where
258 isTypeableInfo = \case
259 NonRec name _ -> any (`isPrefixOf` getOccString name) ["$krep", "$tc", "$trModule"]
260 Rec _ -> False
262-- | Like 'runGhc' but much faster (400x), with less IO and no file dependency
263runGhcFast :: Ghc a -> IO a
264-- copied from GHC with the nasty bits dropped
265runGhcFast act = do
266 ref <- newIORef (error "empty session")
267 let session = Session ref
268 flip unGhc session $ do
269 dflags <- liftIO $ initDynFlags $ defaultDynFlags fakeSettings fakeLlvmConfig
270 liftIO $ setUnsafeGlobalDynFlags dflags
271 env <- liftIO $ newHscEnv dflags
272 setSession env
273 withCleanupSession act
275-- These settings are mostly undefined, but define just enough for what we want to do (which isn't code gen)
276fakeSettings :: Settings
277fakeSettings = Settings
278 {sTargetPlatform=platform
279 ,sPlatformConstants=platformConstants
280 ,sProjectVersion=cProjectVersion
281 ,sProgramName="ghc"
282 ,sOpt_P_fingerprint=fingerprint0
283 }
284 where
285 platform = Platform{platformWordSize=8, platformOS=OSUnknown, platformUnregisterised=True}
286 platformConstants = PlatformConstants{pc_DYNAMIC_BY_DEFAULT=False,pc_WORD_SIZE=8}
288fakeLlvmConfig :: (LlvmTargets, LlvmPasses)
289fakeLlvmConfig = ([], [])
292-- Orphan instances for types from the GHC API.
293instance Show CoreModule where show = prettyPrint
294instance NFData CoreModule where rnf !_ = ()
296instance Show RdrName where show = prettyPrint
297instance NFData RdrName where rnf !_ = ()
299instance Show InstalledUnitId where
300 show = installedUnitIdString
302instance NFData InstalledUnitId where
303 rnf = rwhnf
305instance NFData SB.StringBuffer where
306 rnf = rwhnf
308instance Show Module where
309 show = moduleNameString . moduleName
311instance Show ComponentId where show = prettyPrint
312instance Show SourcePackageId where show = prettyPrint
313instance Show ModuleName where show = prettyPrint
314instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
315instance Show PackageName where show = prettyPrint
316instance Show Packages.PackageState where show _ = "PackageState"
317instance Show Name where show = prettyPrint
319type RealLocated = GenLocated RealSrcSpan