git.iko.soy/ghcide
on master help sign in
Support TemplateHaskell (#222)

* First attempt at TH support * Update TcModuleResult when generating core * Be a bit more cautious when asking for bytecode * Check need for bytecode not only in source file itself, also in global information * Add a test (based on #212) * Fix test (thanks, @jinwoo) * Split GenerateCore and GenerateByteCode

commit481ca019a36f3252bd5a786b49bbcb3798045679 authorAlejandro Serrano <trupill@gmail.com> dateTue 10 Dec 2019, 13:16 (7 years ago) parent7f3b0f6
6 files changed+104−27
compare with master
unifiedsplit
src/Development/IDE/Core/Compile.hs+18−9 src/Development/IDE/Core/RuleTypes.hs+11−2 src/Development/IDE/Core/Rules.hs+28−14 src/Development/IDE/GHC/Orphans.hs+7−1 src/Development/IDE/GHC/Util.hs+9−1 test/exe/Main.hs+31
src/Development/IDE/Core/Compile.hs+18−9
@@ -15,6 +15,7 @@ module Development.IDE.Core.Compile
1515 , computePackageDeps
1616 , addRelativeImport
1717 , mkTcModuleResult
18+ , generateByteCode
1819 ) where
1920
2021import Development.IDE.Core.RuleTypes
@@ -41,6 +42,7 @@ import qualified GHC
4142import GhcMonad
4243import GhcPlugins as GHC hiding (fst3, (<>))
4344import qualified HeaderInfo as Hdr
45+import HscMain (hscInteractive)
4446import MkIface
4547import StringBuffer as SB
4648import TidyPgm
@@ -122,7 +124,7 @@ compileModule
122124 :: HscEnv
123125 -> [TcModuleResult]
124126 -> TcModuleResult
125− -> IO ([FileDiagnostic], Maybe CoreModule)
127+ -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
126128compileModule packageState deps tmr =
127129 fmap (either (, Nothing) (second Just)) $
128130 runGhcEnv packageState $
@@ -138,15 +140,22 @@ compileModule packageState deps tmr =
138140 GHC.dm_core_module <$> GHC.desugarModule tm'
139141
140142 -- give variables unique OccNames
141− (tidy, details) <- liftIO $ tidyProgram session desugar
143+ (guts, details) <- liftIO $ tidyProgram session desugar
144+ return (map snd warnings, (mg_safe_haskell desugar, guts, details))
142145
143− let core = CoreModule
144− (cg_module tidy)
145− (md_types details)
146− (cg_binds tidy)
147− (mg_safe_haskell desugar)
148−
149− return (map snd warnings, core)
146+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
147+generateByteCode hscEnv deps tmr guts =
148+ fmap (either (, Nothing) (second Just)) $
149+ runGhcEnv hscEnv $
150+ catchSrcErrors "bytecode" $ do
151+ setupEnv (deps ++ [tmr])
152+ session <- getSession
153+ (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
154+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
155+ let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
156+ let unlinked = BCOs bytecode sptEntries
157+ let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
158+ pure (map snd warnings, linkable)
150159
151160demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
152161demoteTypeErrorsToWarnings =
src/Development/IDE/Core/RuleTypes.hs+11−2
@@ -24,7 +24,7 @@ import GHC.Generics (Generic)
2424
2525import GHC
2626import Module (InstalledUnitId)
27−import HscTypes (HomeModInfo)
27+import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
2828import Development.IDE.GHC.Compat
2929
3030import Development.IDE.Spans.Type
@@ -65,7 +65,10 @@ type instance RuleResult TypeCheck = TcModuleResult
6565type instance RuleResult GetSpanInfo = [SpanInfo]
6666
6767-- | Convert to Core, requires TypeCheck*
68−type instance RuleResult GenerateCore = CoreModule
68+type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
69+
70+-- | Generate byte code for template haskell.
71+type instance RuleResult GenerateByteCode = Linkable
6972
7073-- | A GHC session that we reuse.
7174type instance RuleResult GhcSession = HscEnvEq
@@ -131,6 +134,12 @@ instance Hashable GenerateCore
131134instance NFData GenerateCore
132135instance Binary GenerateCore
133136
137+data GenerateByteCode = GenerateByteCode
138+ deriving (Eq, Show, Typeable, Generic)
139+instance Hashable GenerateByteCode
140+instance NFData GenerateByteCode
141+instance Binary GenerateByteCode
142+
134143data GhcSession = GhcSession
135144 deriving (Eq, Show, Typeable, Generic)
136145instance Hashable GhcSession
src/Development/IDE/Core/Rules.hs+28−14
@@ -17,7 +17,6 @@ module Development.IDE.Core.Rules(
1717 runAction, useE, useNoFileE, usesE,
1818 toIdeResult, defineNoFile,
1919 mainRule,
20− getGhcCore,
2120 getAtPoint,
2221 getDefinition,
2322 getDependencies,
@@ -55,10 +54,12 @@ import Development.Shake hiding (Diagnostic)
5554import Development.IDE.Core.RuleTypes
5655
5756import GHC hiding (parseModule, typecheckModule)
57+import qualified GHC.LanguageExtensions as LangExt
5858import Development.IDE.GHC.Compat
5959import UniqSupply
6060import NameCache
6161import HscTypes
62+import DynFlags (xopt)
6263import GHC.Generics(Generic)
6364
6465import qualified Development.IDE.Spans.AtPoint as AtPoint
@@ -92,16 +93,6 @@ defineNoFile f = define $ \k file -> do
9293------------------------------------------------------------
9394-- Exposed API
9495
95−
96−-- | Generate the GHC Core for the supplied file and its dependencies.
97−getGhcCore :: NormalizedFilePath -> Action (Maybe [CoreModule])
98−getGhcCore file = runMaybeT $ do
99− files <- transitiveModuleDeps <$> useE GetDependencies file
100− pms <- usesE GetParsedModule $ files ++ [file]
101− usesE GenerateCore $ map fileFromParsedModule pms
102−
103−
104−
10596-- | Get all transitive file dependencies of a given module.
10697-- Does not include the file itself.
10798getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
@@ -281,13 +272,27 @@ typeCheckRule =
281272 define $ \TypeCheck file -> do
282273 pm <- use_ GetParsedModule file
283274 deps <- use_ GetDependencies file
284− tms <- uses_ TypeCheck (transitiveModuleDeps deps)
285− setPriority priorityTypeCheck
286275 packageState <- hscEnv <$> use_ GhcSession file
276+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
277+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
278+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
279+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
280+ tms <- if any_uses_th_qq
281+ -- If we use TH or QQ, we must obtain the bytecode
282+ then do
283+ bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
284+ tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
285+ pure (zipWith addByteCode bytecodes tmrs)
286+ else uses_ TypeCheck (transitiveModuleDeps deps)
287+ setPriority priorityTypeCheck
287288 IdeOptions{ optDefer = defer} <- getIdeOptions
288289 liftIO $ typecheckModule defer packageState tms pm
290+ where
291+ uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
292+ addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
293+ addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
289294
290−generateCore :: NormalizedFilePath -> Action (IdeResult CoreModule)
295+generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
291296generateCore file = do
292297 deps <- use_ GetDependencies file
293298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
@@ -299,6 +304,14 @@ generateCoreRule :: Rules ()
299304generateCoreRule =
300305 define $ \GenerateCore -> generateCore
301306
307+generateByteCodeRule :: Rules ()
308+generateByteCodeRule =
309+ define $ \GenerateByteCode file -> do
310+ deps <- use_ GetDependencies file
311+ (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
312+ session <- hscEnv <$> use_ GhcSession file
313+ (_, guts, _) <- use_ GenerateCore file
314+ liftIO $ generateByteCode session tms tm guts
302315
303316-- A local rule type to get caching. We want to use newCache, but it has
304317-- thread killed exception issues, so we lift it to a full rule.
@@ -345,6 +358,7 @@ mainRule = do
345358 typeCheckRule
346359 getSpanInfoRule
347360 generateCoreRule
361+ generateByteCodeRule
348362 loadGhcSession
349363 getHieFileRule
350364
src/Development/IDE/GHC/Orphans.hs+7−1
@@ -20,7 +20,13 @@ import Development.IDE.GHC.Util
2020-- Orphan instances for types from the GHC API.
2121instance Show CoreModule where show = prettyPrint
2222instance NFData CoreModule where rnf = rwhnf
23−
23+instance Show CgGuts where show = prettyPrint . cg_module
24+instance NFData CgGuts where rnf = rwhnf
25+instance Show ModDetails where show = const "<moddetails>"
26+instance NFData ModDetails where rnf = rwhnf
27+instance NFData SafeHaskellMode where rnf = rwhnf
28+instance Show Linkable where show = prettyPrint
29+instance NFData Linkable where rnf = rwhnf
2430
2531instance Show InstalledUnitId where
2632 show = installedUnitIdString
src/Development/IDE/GHC/Util.hs+9−1
@@ -19,7 +19,8 @@ module Development.IDE.GHC.Util(
1919 textToStringBuffer,
2020 moduleImportPath,
2121 HscEnvEq, hscEnv, newHscEnvEq,
22− readFileUtf8
22+ readFileUtf8,
23+ cgGutsToCoreModule
2324 ) where
2425
2526import Config
@@ -146,3 +147,10 @@ instance NFData HscEnvEq where
146147
147148readFileUtf8 :: FilePath -> IO T.Text
148149readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
150+
151+cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
152+cgGutsToCoreModule safeMode guts modDetails = CoreModule
153+ (cg_module guts)
154+ (md_types modDetails)
155+ (cg_binds guts)
156+ safeMode
test/exe/Main.hs+31
@@ -41,6 +41,7 @@ main = defaultMain $ testGroup "HIE"
4141 , codeActionTests
4242 , findDefinitionAndHoverTests
4343 , pluginTests
44+ , thTests
4445 ]
4546
4647initializeResponseTests :: TestTree
@@ -833,6 +834,36 @@ pluginTests = testSessionWait "plugins" $ do
833834 )
834835 ]
835836
837+thTests :: TestTree
838+thTests =
839+ testGroup
840+ "TemplateHaskell"
841+ [ -- Test for https://github.com/digital-asset/ghcide/pull/212
842+ testSessionWait "load" $ do
843+ let sourceA =
844+ T.unlines
845+ [ "{-# LANGUAGE PackageImports #-}",
846+ "{-# LANGUAGE TemplateHaskell #-}",
847+ "module A where",
848+ "import \"template-haskell\" Language.Haskell.TH",
849+ "a :: Integer",
850+ "a = $(litE $ IntegerL 3)"
851+ ]
852+ sourceB =
853+ T.unlines
854+ [ "{-# LANGUAGE PackageImports #-}",
855+ "{-# LANGUAGE TemplateHaskell #-}",
856+ "module B where",
857+ "import A",
858+ "import \"template-haskell\" Language.Haskell.TH",
859+ "b :: Integer",
860+ "b = $(litE $ IntegerL $ a) + n"
861+ ]
862+ _ <- openDoc' "A.hs" "haskell" sourceA
863+ _ <- openDoc' "B.hs" "haskell" sourceB
864+ expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
865+ ]
866+
836867xfail :: TestTree -> String -> TestTree
837868xfail = flip expectFailBecause
838869