481ca01 · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Support TemplateHaskell (#222)

481ca01Alejandro Serrano7 years ago

src/Development/IDE/Core/Compile.hs+18−9

compare with master

unifiedsplit

@@ -15,6 +15,7 @@ module Development.IDE.Core.Compile

15 , computePackageDeps

16 , addRelativeImport

17 , mkTcModuleResult

18+ , generateByteCode

18 ) where

19 ) where

20import Development.IDE.Core.RuleTypes

21import Development.IDE.Core.RuleTypes

@@ -41,6 +42,7 @@ import qualified GHC

41import GhcMonad

42import GhcMonad

42import GhcPlugins as GHC hiding (fst3, (<>))

43import GhcPlugins as GHC hiding (fst3, (<>))

43import qualified HeaderInfo as Hdr

44import qualified HeaderInfo as Hdr

45+import HscMain (hscInteractive)

44import MkIface

46import MkIface

45import StringBuffer as SB

47import StringBuffer as SB

46import TidyPgm

48import TidyPgm

@@ -122,7 +124,7 @@ compileModule

122 :: HscEnv

124 :: HscEnv

123 -> [TcModuleResult]

125 -> [TcModuleResult]

124 -> TcModuleResult

126 -> TcModuleResult

125− -> IO ([FileDiagnostic], Maybe CoreModule)

127+ -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))

126compileModule packageState deps tmr =

128compileModule packageState deps tmr =

127 fmap (either (, Nothing) (second Just)) $

129 fmap (either (, Nothing) (second Just)) $

128 runGhcEnv packageState $

130 runGhcEnv packageState $

@@ -138,15 +140,22 @@ compileModule packageState deps tmr =

138 GHC.dm_core_module <$> GHC.desugarModule tm'

140 GHC.dm_core_module <$> GHC.desugarModule tm'

139

141

140 -- give variables unique OccNames

142 -- 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))

142

145

143− let core = CoreModule

146+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)

144− (cg_module tidy)

147+generateByteCode hscEnv deps tmr guts =

145− (md_types details)

148+ fmap (either (, Nothing) (second Just)) $

146− (cg_binds tidy)

149+ runGhcEnv hscEnv $

147− (mg_safe_haskell desugar)

150+ catchSrcErrors "bytecode" $ do

148−

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]

149− return (map snd warnings, core)

158+ pure (map snd warnings, linkable)

150

159

151demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule

160demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule

152demoteTypeErrorsToWarnings =

161demoteTypeErrorsToWarnings =

src/Development/IDE/Core/RuleTypes.hs+11−2

@@ -24,7 +24,7 @@ import GHC.Generics (Generic)

25import GHC

26import Module (InstalledUnitId)

27−import HscTypes (HomeModInfo)

27+import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)

28import Development.IDE.GHC.Compat

30import Development.IDE.Spans.Type

@@ -65,7 +65,10 @@ type instance RuleResult TypeCheck = TcModuleResult

65type instance RuleResult GetSpanInfo = [SpanInfo]

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

70-- | A GHC session that we reuse.

73-- | A GHC session that we reuse.

71type instance RuleResult GhcSession = HscEnvEq

74type instance RuleResult GhcSession = HscEnvEq

@@ -131,6 +134,12 @@ instance Hashable GenerateCore

131instance NFData GenerateCore

134instance NFData GenerateCore

132instance Binary GenerateCore

135instance Binary GenerateCore

133

136

137+data GenerateByteCode = GenerateByteCode

138+ deriving (Eq, Show, Typeable, Generic)

139+instance Hashable GenerateByteCode

140+instance NFData GenerateByteCode

141+instance Binary GenerateByteCode

142+

134data GhcSession = GhcSession

143data GhcSession = GhcSession

135 deriving (Eq, Show, Typeable, Generic)

144 deriving (Eq, Show, Typeable, Generic)

136instance Hashable GhcSession

145instance Hashable GhcSession

src/Development/IDE/Core/Rules.hs+28−14

@@ -17,7 +17,6 @@ module Development.IDE.Core.Rules(

17 runAction, useE, useNoFileE, usesE,

18 toIdeResult, defineNoFile,

19 mainRule,

20− getGhcCore,

21 getAtPoint,

20 getAtPoint,

22 getDefinition,

21 getDefinition,

23 getDependencies,

22 getDependencies,

@@ -55,10 +54,12 @@ import Development.Shake hiding (Diagnostic)

55import Development.IDE.Core.RuleTypes

54import Development.IDE.Core.RuleTypes

57import GHC hiding (parseModule, typecheckModule)

56import GHC hiding (parseModule, typecheckModule)

57+import qualified GHC.LanguageExtensions as LangExt

58import Development.IDE.GHC.Compat

59import UniqSupply

60import NameCache

61import HscTypes

62+import DynFlags (xopt)

62import GHC.Generics(Generic)

63import GHC.Generics(Generic)

64import qualified Development.IDE.Spans.AtPoint as AtPoint

65import qualified Development.IDE.Spans.AtPoint as AtPoint

@@ -92,16 +93,6 @@ defineNoFile f = define $ \k file -> do

92------------------------------------------------------------

93------------------------------------------------------------

93-- Exposed API

94-- Exposed API

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−

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

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

106-- Does not include the file itself.

97-- Does not include the file itself.

107getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])

98getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])

@@ -281,13 +272,27 @@ typeCheckRule =

281 define $ \TypeCheck file -> do

272 define $ \TypeCheck file -> do

282 pm <- use_ GetParsedModule file

273 pm <- use_ GetParsedModule file

283 deps <- use_ GetDependencies file

274 deps <- use_ GetDependencies file

284− tms <- uses_ TypeCheck (transitiveModuleDeps deps)

285− setPriority priorityTypeCheck

286 packageState <- hscEnv <$> use_ GhcSession file

275 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

287 IdeOptions{ optDefer = defer} <- getIdeOptions

288 IdeOptions{ optDefer = defer} <- getIdeOptions

288 liftIO $ typecheckModule defer packageState tms pm

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

289

294

290−generateCore :: NormalizedFilePath -> Action (IdeResult CoreModule)

295+generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

291generateCore file = do

296generateCore file = do

292 deps <- use_ GetDependencies file

297 deps <- use_ GetDependencies file

293 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

@@ -299,6 +304,14 @@ generateCoreRule :: Rules ()

299generateCoreRule =

304generateCoreRule =

300 define $ \GenerateCore -> generateCore

305 define $ \GenerateCore -> generateCore

301

306

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

302

315

303-- A local rule type to get caching. We want to use newCache, but it has

316-- A local rule type to get caching. We want to use newCache, but it has

304-- thread killed exception issues, so we lift it to a full rule.

317-- thread killed exception issues, so we lift it to a full rule.

@@ -345,6 +358,7 @@ mainRule = do

345 typeCheckRule

358 typeCheckRule

346 getSpanInfoRule

359 getSpanInfoRule

347 generateCoreRule

360 generateCoreRule

361+ generateByteCodeRule

348 loadGhcSession

362 loadGhcSession

349 getHieFileRule

363 getHieFileRule

350

364

src/Development/IDE/GHC/Orphans.hs+7−1

@@ -20,7 +20,13 @@ import Development.IDE.GHC.Util

20-- Orphan instances for types from the GHC API.

21instance Show CoreModule where show = prettyPrint

22instance 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

25instance Show InstalledUnitId where

31instance Show InstalledUnitId where

26 show = installedUnitIdString

32 show = installedUnitIdString

src/Development/IDE/GHC/Util.hs+9−1

@@ -19,7 +19,8 @@ module Development.IDE.GHC.Util(

19 textToStringBuffer,

20 moduleImportPath,

21 HscEnvEq, hscEnv, newHscEnvEq,

22− readFileUtf8

22+ readFileUtf8,

23+ cgGutsToCoreModule

23 ) where

24 ) where

25import Config

26import Config

@@ -146,3 +147,10 @@ instance NFData HscEnvEq where

146

147

147readFileUtf8 :: FilePath -> IO T.Text

148readFileUtf8 :: FilePath -> IO T.Text

148readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

149readFileUtf8 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"

41 , codeActionTests

42 , findDefinitionAndHoverTests

43 , pluginTests

44+ , thTests

44 ]

45 ]

46initializeResponseTests :: TestTree

47initializeResponseTests :: TestTree

@@ -833,6 +834,36 @@ pluginTests = testSessionWait "plugins" $ do

833 )

834 )

834 ]

835 ]

835

836

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+

836xfail :: TestTree -> String -> TestTree

867xfail :: TestTree -> String -> TestTree

837xfail = flip expectFailBecause

868xfail = flip expectFailBecause

838

869