Skip to content

Commit 8d5cbe1

Browse files
konnmpickeringmergify[bot]
authored
Splice Plugin: expands TH splices and QuasiQuotes (#759)
* Implements splice location detection * Corrects detection logic * Changed to use (bogus) message for code action * Splice location * Extract `Ide.TreeTransform` as an independent package * It once worked, but stops... * Now it works for inplace expansion for expressions * generalises tree transformation to general AST element * Done for Types and Patterns! * Disabled "commented" style of expansion * kills redundant imports * Updates cabal.project * Nix fix * Nix fix, fix * Throws away loading hacks entirely * Type adjusted for inverse dependency * Resolves merge conflicts * WIP: Support hover and goto definition for top-level splices I can't work out how to properly integrate this information into the .hie file machinery. Perhaps it would be better to upstream this. * Modifies splice information to store both spliced expression and expanded ones as well * Avoid name collision * formatting erros * Safer error handling * Rewrote using updated ghcide `TypeCheck` results * Use `liftRnf rwhnf` to force spine of lists * Stop using `defaultRunMeta` directly to avoid override of preexisting hooks * Error report * Add splice information into HIE generation. * Resolves interace conflict * Add test * Changes to use ParsedModule to detect Splice CodeLens * formatted * Implements golden test * mzero for HsDecl * Decl Splice * Workaround for Decl expansion and support type-errored macro expansion. * Only setting up dflags correcly would suffice * Removes lines accidentally added * Regression tests for Declaration splice and kind-error ones * Workaround for GHC 8.8 * Revert "Workaround for GHC 8.8" This reverts commit 056f769. * Unsupport pattern splices GHC 8.8 * Corrects line position in GoToHover * Increases wait time * Includes only related changes only * Optimises `something'` * Adds hie.yaml * circie ci: Modifies stack-8.10.3.yaml * Forgot to update dflags in auto-expansion with default strategy * Forgot to add golden file * A dummy commit to run CI * Workaround for GHC 8.8 pattern splices Co-authored-by: Matthew Pickering <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 8b7090f commit 8d5cbe1

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

71 files changed

+1829
-137
lines changed

‎cabal.project

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,12 +4,14 @@ packages:
44
./shake-bench
55
./ghcide
66
./hls-plugin-api
7+
./hls-exactprint-utils
78
./plugins/tactics
89
./plugins/hls-class-plugin
910
./plugins/hls-eval-plugin
1011
./plugins/hls-explicit-imports-plugin
1112
./plugins/hls-hlint-plugin
1213
./plugins/hls-retrie-plugin
14+
./plugins/hls-splice-plugin
1315

1416
tests: true
1517

‎exe/Plugins.hs

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,10 @@ import Ide.Plugin.ModuleName as ModuleName
4545
import Ide.Plugin.Pragmas as Pragmas
4646
#endif
4747

48+
#if splice
49+
import Ide.Plugin.Splice as Splice
50+
#endif
51+
4852
-- formatters
4953

5054
#if floskell
@@ -120,6 +124,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
120124
#endif
121125
#if hlint
122126
, Hlint.descriptor "hlint"
127+
#endif
128+
#if splice
129+
, Splice.descriptor "splice"
123130
#endif
124131
]
125132
examplePlugins =

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,7 @@ library
4646
data-default,
4747
deepseq,
4848
directory,
49+
dlist,
4950
extra,
5051
fuzzy,
5152
filepath,

‎ghcide/src/Development/IDE/Core/Compile.hs

Lines changed: 69 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -71,8 +71,11 @@ import StringBuffer as SB
7171
import TcRnMonad
7272
import TcIface (typecheckIface)
7373
import TidyPgm
74+
import Hooks
75+
import TcSplice
7476

7577
import Control.Exception.Safe
78+
import Control.Lens hiding (List)
7679
import Control.Monad.Extra
7780
import Control.Monad.Except
7881
import Control.Monad.Trans.Except
@@ -85,10 +88,12 @@ import Data.Maybe
8588
import qualified Data.Map.Strict as Map
8689
import System.FilePath
8790
import System.Directory
88-
import System.IO.Extra
91+
import System.IO.Extra ( fixIO, newTempFileWithin )
8992
import Control.Exception (evaluate)
9093
import TcEnv (tcLookup)
94+
import qualified Data.DList as DL
9195
import Data.Time (UTCTime, getCurrentTime)
96+
import Bag
9297
import Linker (unload)
9398
import qualified GHC.LanguageExtensions as LangExt
9499
import PrelNames
@@ -144,21 +149,61 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
144149
where
145150
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
146151

152+
-- | Add a Hook to the DynFlags which captures and returns the
153+
-- typechecked splices before they are run. This information
154+
-- is used for hover.
155+
captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)
156+
captureSplices dflags k = do
157+
splice_ref <- newIORef mempty
158+
res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)})
159+
splices <- readIORef splice_ref
160+
return (res, splices)
161+
where
162+
addSpliceHook :: IORef Splices -> Hooks -> Hooks
163+
addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) }
164+
165+
splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM
166+
splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of
167+
(MetaE f) -> do
168+
expr' <- metaRequestE hook e
169+
liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :)
170+
pure $ f expr'
171+
(MetaP f) -> do
172+
pat' <- metaRequestP hook e
173+
liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :)
174+
pure $ f pat'
175+
(MetaT f) -> do
176+
type' <- metaRequestT hook e
177+
liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :)
178+
pure $ f type'
179+
(MetaD f) -> do
180+
decl' <- metaRequestD hook e
181+
liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :)
182+
pure $ f decl'
183+
(MetaAW f) -> do
184+
aw' <- metaRequestAW hook e
185+
liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :)
186+
pure $ f aw'
187+
188+
147189
tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
148190
tcRnModule hsc_env keep_lbls pmod = do
149191
let ms = pm_mod_summary pmod
150192
hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
151193

152194
unload hsc_env_tmp keep_lbls
153-
(tc_gbl_env, mrn_info) <-
154-
hscTypecheckRename hsc_env_tmp ms $
155-
HsParsedModule { hpm_module = parsedSource pmod,
156-
hpm_src_files = pm_extra_src_files pmod,
157-
hpm_annotations = pm_annotations pmod }
195+
196+
((tc_gbl_env, mrn_info), splices)
197+
<- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags ->
198+
do let hsc_env_tmp = hsc_env { hsc_dflags = dflags }
199+
hscTypecheckRename hsc_env_tmp ms $
200+
HsParsedModule { hpm_module = parsedSource pmod,
201+
hpm_src_files = pm_extra_src_files pmod,
202+
hpm_annotations = pm_annotations pmod }
158203
let rn_info = case mrn_info of
159204
Just x -> x
160205
Nothing -> error "no renamed info tcRnModule"
161-
pure (TcModuleResult pmod rn_info tc_gbl_env False)
206+
pure (TcModuleResult pmod rn_info tc_gbl_env splices False)
162207

163208
mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
164209
mkHiFileResultNoCompile session tcm = do
@@ -385,11 +430,26 @@ atomicFileWrite targetPath write = do
385430

386431
generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type))
387432
generateHieAsts hscEnv tcm =
388-
handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $
389-
Just <$> GHC.enrichHie (tcg_binds $ tmrTypechecked tcm) (tmrRenamed tcm)
433+
handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do
434+
-- These varBinds use unitDataConId but it could be anything as the id name is not used
435+
-- during the hie file generation process. It's a workaround for the fact that the hie modules
436+
-- don't export an interface which allows for additional information to be added to hie files.
437+
let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm))
438+
real_binds = tcg_binds $ tmrTypechecked tcm
439+
Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm)
390440
where
391441
dflags = hsc_dflags hscEnv
392442

443+
spliceExpresions :: Splices -> [LHsExpr GhcTc]
444+
spliceExpresions Splices{..} =
445+
DL.toList $ mconcat
446+
[ DL.fromList $ map fst exprSplices
447+
, DL.fromList $ map fst patSplices
448+
, DL.fromList $ map fst typeSplices
449+
, DL.fromList $ map fst declSplices
450+
, DL.fromList $ map fst awSplices
451+
]
452+
393453
writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
394454
writeHieFile hscEnv mod_summary exports ast source =
395455
handleGenerationErrors dflags "extended interface write/compression" $ do

‎ghcide/src/Development/IDE/Core/RuleTypes.hs

Lines changed: 37 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33

44
{-# LANGUAGE FlexibleInstances #-}
55
{-# LANGUAGE PatternSynonyms #-}
6+
{-# LANGUAGE TemplateHaskell #-}
67
{-# LANGUAGE TypeFamilies #-}
78
{-# LANGUAGE DerivingStrategies #-}
89

@@ -14,6 +15,7 @@ module Development.IDE.Core.RuleTypes(
1415
) where
1516

1617
import Control.DeepSeq
18+
import Control.Lens
1719
import Data.Aeson.Types (Value)
1820
import Data.Binary
1921
import Development.IDE.Import.DependencyInformation
@@ -40,6 +42,7 @@ import qualified Data.ByteString.Char8 as BS
4042
import Development.IDE.Types.Options (IdeGhcSession)
4143
import Data.Text (Text)
4244
import Data.Int (Int64)
45+
import GHC.Serialized (Serialized)
4346

4447
data LinkableType = ObjectLinkable | BCOLinkable
4548
deriving (Eq,Ord,Show)
@@ -90,13 +93,42 @@ newtype ImportMap = ImportMap
9093
} deriving stock Show
9194
deriving newtype NFData
9295

96+
data Splices = Splices
97+
{ exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)]
98+
, patSplices :: [(LHsExpr GhcTc, LPat GhcPs)]
99+
, typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)]
100+
, declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])]
101+
, awSplices :: [(LHsExpr GhcTc, Serialized)]
102+
}
103+
104+
instance Semigroup Splices where
105+
Splices e p t d aw <> Splices e' p' t' d' aw' =
106+
Splices
107+
(e <> e')
108+
(p <> p')
109+
(t <> t')
110+
(d <> d')
111+
(aw <> aw')
112+
113+
instance Monoid Splices where
114+
mempty = Splices mempty mempty mempty mempty mempty
115+
116+
instance NFData Splices where
117+
rnf Splices {..} =
118+
liftRnf rwhnf exprSplices `seq`
119+
liftRnf rwhnf patSplices `seq`
120+
liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` ()
121+
93122
-- | Contains the typechecked module and the OrigNameCache entry for
94123
-- that module.
95124
data TcModuleResult = TcModuleResult
96125
{ tmrParsed :: ParsedModule
97126
, tmrRenamed :: RenamedSource
98127
, tmrTypechecked :: TcGblEnv
99-
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
128+
, tmrTopLevelSplices :: Splices
129+
-- ^ Typechecked splice information
130+
, tmrDeferedError :: !Bool
131+
-- ^ Did we defer any type errors for this module?
100132
}
101133
instance Show TcModuleResult where
102134
show = show . pm_mod_summary . tmrParsed
@@ -398,3 +430,7 @@ data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
398430
instance Hashable GhcSessionIO
399431
instance NFData GhcSessionIO
400432
instance Binary GhcSessionIO
433+
434+
makeLensesWith
435+
(lensRules & lensField .~ mappingNamer (pure . (++ "L")))
436+
''Splices

‎ghcide/src/Development/IDE/GHC/Orphans.hs

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,12 +12,15 @@ module Development.IDE.GHC.Orphans() where
1212

1313
import Bag
1414
import Control.DeepSeq
15+
import Data.Aeson
1516
import Data.Hashable
1617
import Development.IDE.GHC.Compat
1718
import Development.IDE.GHC.Util
1819
import GHC ()
1920
import GhcPlugins
2021
import qualified StringBuffer as SB
22+
import Data.Text (Text)
23+
import Data.String (IsString(fromString))
2124

2225

2326
-- Orphan instances for types from the GHC API.
@@ -94,6 +97,37 @@ instance NFData a => NFData (IdentifierDetails a) where
9497
instance NFData RealSrcSpan where
9598
rnf = rwhnf
9699

100+
srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,
101+
srcSpanEndLineTag, srcSpanEndColTag :: Text
102+
srcSpanFileTag = "srcSpanFile"
103+
srcSpanStartLineTag = "srcSpanStartLine"
104+
srcSpanStartColTag = "srcSpanStartCol"
105+
srcSpanEndLineTag = "srcSpanEndLine"
106+
srcSpanEndColTag = "srcSpanEndCol"
107+
108+
instance ToJSON RealSrcSpan where
109+
toJSON spn =
110+
object
111+
[ srcSpanFileTag .= unpackFS (srcSpanFile spn)
112+
, srcSpanStartLineTag .= srcSpanStartLine spn
113+
, srcSpanStartColTag .= srcSpanStartCol spn
114+
, srcSpanEndLineTag .= srcSpanEndLine spn
115+
, srcSpanEndColTag .= srcSpanEndCol spn
116+
]
117+
118+
instance FromJSON RealSrcSpan where
119+
parseJSON = withObject "object" $ \obj -> do
120+
file <- fromString <$> (obj .: srcSpanFileTag)
121+
mkRealSrcSpan
122+
<$> (mkRealSrcLoc file
123+
<$> obj .: srcSpanStartLineTag
124+
<*> obj .: srcSpanStartColTag
125+
)
126+
<*> (mkRealSrcLoc file
127+
<$> obj .: srcSpanEndLineTag
128+
<*> obj .: srcSpanEndColTag
129+
)
130+
97131
instance NFData Type where
98132
rnf = rwhnf
99133

‎ghcide/test/data/hover/GotoHover.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE OverloadedStrings #-}
1+
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
22
{- HLINT ignore -}
33
module GotoHover ( module GotoHover) where
44
import Data.Text (Text, pack)
@@ -56,5 +56,8 @@ outer = undefined inner where
5656
imported :: Bar
5757
imported = foo
5858

59+
aa2 :: Bool
60+
aa2 = $(id [| True |])
61+
5962
hole :: Int
6063
hole = _

‎ghcide/test/exe/Main.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2520,7 +2520,7 @@ findDefinitionAndHoverTests = let
25202520
, testGroup "hover" $ mapMaybe snd tests
25212521
, checkFileCompiles sourceFilePath $
25222522
expectDiagnostics
2523-
[ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ]
2523+
[ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ]
25242524
, testGroup "type-definition" typeDefinitionTests ]
25252525

25262526
typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"
@@ -2570,10 +2570,11 @@ findDefinitionAndHoverTests = let
25702570
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
25712571
outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
25722572
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
2573-
holeL60 = Position 59 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
2573+
holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
25742574
cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]]
25752575
imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
25762576
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
2577+
thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]
25772578
in
25782579
mkFindTests
25792580
-- def hover look expect
@@ -2620,6 +2621,7 @@ findDefinitionAndHoverTests = let
26202621
, test no skip cccL17 docLink "Haddock html links"
26212622
, testM yes yes imported importedSig "Imported symbol"
26222623
, testM yes yes reexported reexportedSig "Imported symbol (reexported)"
2624+
, test no yes thLocL57 thLoc "TH Splice Hover"
26232625
]
26242626
where yes, broken :: (TestTree -> Maybe TestTree)
26252627
yes = Just -- test should run and pass

‎haskell-language-server.cabal

Lines changed: 15 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -127,6 +127,11 @@ flag pragmas
127127
default: False
128128
manual: True
129129

130+
flag splice
131+
description: Enable splice plugin
132+
default: False
133+
manual: True
134+
130135
-- formatters
131136

132137
flag floskell
@@ -201,6 +206,11 @@ common pragmas
201206
other-modules: Ide.Plugin.Pragmas
202207
cpp-options: -Dpragmas
203208

209+
common splice
210+
if flag(splice) || flag(all-plugins)
211+
build-depends: hls-splice-plugin
212+
cpp-options: -Dsplice
213+
204214
-- formatters
205215

206216
common floskell
@@ -251,6 +261,7 @@ executable haskell-language-server
251261
, hlint
252262
, moduleName
253263
, pragmas
264+
, splice
254265
, floskell
255266
, fourmolu
256267
, ormolu
@@ -384,8 +395,9 @@ test-suite func-test
384395
, tasty-ant-xml >=1.1.6
385396
, tasty-golden
386397
, tasty-rerun
398+
, ghcide
387399

388-
hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test
400+
hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src
389401

390402
main-is: Main.hs
391403
other-modules:
@@ -410,6 +422,8 @@ test-suite func-test
410422
Symbol
411423
TypeDefinition
412424
Tactic
425+
Splice
426+
Ide.Plugin.Splice.Types
413427
Ide.Plugin.Tactic.TestTypes
414428

415429
ghc-options:

0 commit comments

Comments
 (0)