Skip to content

Commit

Permalink
Splice Plugin: expands TH splices and QuasiQuotes (haskell#759)
Browse files Browse the repository at this point in the history 
* 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>
  • Loading branch information
@konn @mpickering
@mergify @pepeiborra
3 people authored and pepeiborra committed Jan 9, 2021
1 parent aa66cb2 commit 4a969a9
Show file tree
Hide file tree
Showing 71 changed files with 1,829 additions and 137 deletions.
2 changes: 2 additions & 0 deletions cabal.project
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,12 +4,14 @@ packages:
./shake-bench
./ghcide
./hls-plugin-api
./hls-exactprint-utils
./plugins/tactics
./plugins/hls-class-plugin
./plugins/hls-eval-plugin
./plugins/hls-explicit-imports-plugin
./plugins/hls-hlint-plugin
./plugins/hls-retrie-plugin
./plugins/hls-splice-plugin

tests: true

Expand Down
7 changes: 7 additions & 0 deletions exe/Plugins.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,6 +45,10 @@ import Ide.Plugin.ModuleName as ModuleName
import Ide.Plugin.Pragmas as Pragmas
#endif

#if splice
import Ide.Plugin.Splice as Splice
#endif

-- formatters

#if floskell
Expand Down Expand Up @@ -120,6 +124,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
#endif
#if hlint
, Hlint.descriptor "hlint"
#endif
#if splice
, Splice.descriptor "splice"
#endif
]
examplePlugins =
Expand Down
1 change: 1 addition & 0 deletions ghcide/ghcide.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,7 @@ library
data-default,
deepseq,
directory,
dlist,
extra,
fuzzy,
filepath,
Expand Down
78 changes: 69 additions & 9 deletions ghcide/src/Development/IDE/Core/Compile.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,8 +71,11 @@ import StringBuffer as SB
import TcRnMonad
import TcIface (typecheckIface)
import TidyPgm
import Hooks
import TcSplice

import Control.Exception.Safe
import Control.Lens hiding (List)
import Control.Monad.Extra
import Control.Monad.Except
import Control.Monad.Trans.Except
Expand All @@ -85,10 +88,12 @@ import Data.Maybe
import qualified Data.Map.Strict as Map
import System.FilePath
import System.Directory
import System.IO.Extra
import System.IO.Extra ( fixIO, newTempFileWithin )
import Control.Exception (evaluate)
import TcEnv (tcLookup)
import qualified Data.DList as DL
import Data.Time (UTCTime, getCurrentTime)
import Bag
import Linker (unload)
import qualified GHC.LanguageExtensions as LangExt
import PrelNames
Expand Down Expand Up @@ -144,21 +149,61 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
where
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

-- | Add a Hook to the DynFlags which captures and returns the
-- typechecked splices before they are run. This information
-- is used for hover.
captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices)
captureSplices dflags k = do
splice_ref <- newIORef mempty
res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)})
splices <- readIORef splice_ref
return (res, splices)
where
addSpliceHook :: IORef Splices -> Hooks -> Hooks
addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) }

splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM
splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of
(MetaE f) -> do
expr' <- metaRequestE hook e
liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :)
pure $ f expr'
(MetaP f) -> do
pat' <- metaRequestP hook e
liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :)
pure $ f pat'
(MetaT f) -> do
type' <- metaRequestT hook e
liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :)
pure $ f type'
(MetaD f) -> do
decl' <- metaRequestD hook e
liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :)
pure $ f decl'
(MetaAW f) -> do
aw' <- metaRequestAW hook e
liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :)
pure $ f aw'


tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult
tcRnModule hsc_env keep_lbls pmod = do
let ms = pm_mod_summary pmod
hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }

unload hsc_env_tmp keep_lbls
(tc_gbl_env, mrn_info) <-
hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod,
hpm_annotations = pm_annotations pmod }

((tc_gbl_env, mrn_info), splices)
<- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags ->
do let hsc_env_tmp = hsc_env { hsc_dflags = dflags }
hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod,
hpm_annotations = pm_annotations pmod }
let rn_info = case mrn_info of
Just x -> x
Nothing -> error "no renamed info tcRnModule"
pure (TcModuleResult pmod rn_info tc_gbl_env False)
pure (TcModuleResult pmod rn_info tc_gbl_env splices False)

mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult
mkHiFileResultNoCompile session tcm = do
Expand Down Expand Up @@ -385,11 +430,26 @@ atomicFileWrite targetPath write = do

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

spliceExpresions :: Splices -> [LHsExpr GhcTc]
spliceExpresions Splices{..} =
DL.toList $ mconcat
[ DL.fromList $ map fst exprSplices
, DL.fromList $ map fst patSplices
, DL.fromList $ map fst typeSplices
, DL.fromList $ map fst declSplices
, DL.fromList $ map fst awSplices
]

writeHieFile :: HscEnv -> ModSummary -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic]
writeHieFile hscEnv mod_summary exports ast source =
handleGenerationErrors dflags "extended interface write/compression" $ do
Expand Down
38 changes: 37 additions & 1 deletion ghcide/src/Development/IDE/Core/RuleTypes.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}

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

import Control.DeepSeq
import Control.Lens
import Data.Aeson.Types (Value)
import Data.Binary
import Development.IDE.Import.DependencyInformation
Expand All @@ -40,6 +42,7 @@ import qualified Data.ByteString.Char8 as BS
import Development.IDE.Types.Options (IdeGhcSession)
import Data.Text (Text)
import Data.Int (Int64)
import GHC.Serialized (Serialized)

data LinkableType = ObjectLinkable | BCOLinkable
deriving (Eq,Ord,Show)
Expand Down Expand Up @@ -90,13 +93,42 @@ newtype ImportMap = ImportMap
} deriving stock Show
deriving newtype NFData

data Splices = Splices
{ exprSplices :: [(LHsExpr GhcTc, LHsExpr GhcPs)]
, patSplices :: [(LHsExpr GhcTc, LPat GhcPs)]
, typeSplices :: [(LHsExpr GhcTc, LHsType GhcPs)]
, declSplices :: [(LHsExpr GhcTc, [LHsDecl GhcPs])]
, awSplices :: [(LHsExpr GhcTc, Serialized)]
}

instance Semigroup Splices where
Splices e p t d aw <> Splices e' p' t' d' aw' =
Splices
(e <> e')
(p <> p')
(t <> t')
(d <> d')
(aw <> aw')

instance Monoid Splices where
mempty = Splices mempty mempty mempty mempty mempty

instance NFData Splices where
rnf Splices {..} =
liftRnf rwhnf exprSplices `seq`
liftRnf rwhnf patSplices `seq`
liftRnf rwhnf typeSplices `seq` liftRnf rwhnf declSplices `seq` ()

-- | Contains the typechecked module and the OrigNameCache entry for
-- that module.
data TcModuleResult = TcModuleResult
{ tmrParsed :: ParsedModule
, tmrRenamed :: RenamedSource
, tmrTypechecked :: TcGblEnv
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
, tmrTopLevelSplices :: Splices
-- ^ Typechecked splice information
, tmrDeferedError :: !Bool
-- ^ Did we defer any type errors for this module?
}
instance Show TcModuleResult where
show = show . pm_mod_summary . tmrParsed
Expand Down Expand Up @@ -398,3 +430,7 @@ data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
instance Hashable GhcSessionIO
instance NFData GhcSessionIO
instance Binary GhcSessionIO

makeLensesWith
(lensRules & lensField .~ mappingNamer (pure . (++ "L")))
''Splices
34 changes: 34 additions & 0 deletions ghcide/src/Development/IDE/GHC/Orphans.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,12 +12,15 @@ module Development.IDE.GHC.Orphans() where

import Bag
import Control.DeepSeq
import Data.Aeson
import Data.Hashable
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Util
import GHC ()
import GhcPlugins
import qualified StringBuffer as SB
import Data.Text (Text)
import Data.String (IsString(fromString))


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

srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag,
srcSpanEndLineTag, srcSpanEndColTag :: Text
srcSpanFileTag = "srcSpanFile"
srcSpanStartLineTag = "srcSpanStartLine"
srcSpanStartColTag = "srcSpanStartCol"
srcSpanEndLineTag = "srcSpanEndLine"
srcSpanEndColTag = "srcSpanEndCol"

instance ToJSON RealSrcSpan where
toJSON spn =
object
[ srcSpanFileTag .= unpackFS (srcSpanFile spn)
, srcSpanStartLineTag .= srcSpanStartLine spn
, srcSpanStartColTag .= srcSpanStartCol spn
, srcSpanEndLineTag .= srcSpanEndLine spn
, srcSpanEndColTag .= srcSpanEndCol spn
]

instance FromJSON RealSrcSpan where
parseJSON = withObject "object" $ \obj -> do
file <- fromString <$> (obj .: srcSpanFileTag)
mkRealSrcSpan
<$> (mkRealSrcLoc file
<$> obj .: srcSpanStartLineTag
<*> obj .: srcSpanStartColTag
)
<*> (mkRealSrcLoc file
<$> obj .: srcSpanEndLineTag
<*> obj .: srcSpanEndColTag
)

instance NFData Type where
rnf = rwhnf

Expand Down
5 changes: 4 additions & 1 deletion ghcide/test/data/hover/GotoHover.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
{- HLINT ignore -}
module GotoHover ( module GotoHover) where
import Data.Text (Text, pack)
Expand Down Expand Up @@ -56,5 +56,8 @@ outer = undefined inner where
imported :: Bar
imported = foo

aa2 :: Bool
aa2 = $(id [| True |])

hole :: Int
hole = _
6 changes: 4 additions & 2 deletions ghcide/test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2520,7 +2520,7 @@ findDefinitionAndHoverTests = let
, testGroup "hover" $ mapMaybe snd tests
, checkFileCompiles sourceFilePath $
expectDiagnostics
[ ( "GotoHover.hs", [(DsError, (59, 7), "Found hole: _")]) ]
[ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) ]
, testGroup "type-definition" typeDefinitionTests ]

typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 (pure tcData) "Saturated data con"
Expand Down Expand Up @@ -2570,10 +2570,11 @@ findDefinitionAndHoverTests = let
lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
holeL60 = Position 59 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]]
cccL17 = Position 17 16 ; docLink = [ExpectHoverText ["[Documentation](file:///"]]
imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]
in
mkFindTests
-- def hover look expect
Expand Down Expand Up @@ -2620,6 +2621,7 @@ findDefinitionAndHoverTests = let
, test no skip cccL17 docLink "Haddock html links"
, testM yes yes imported importedSig "Imported symbol"
, testM yes yes reexported reexportedSig "Imported symbol (reexported)"
, test no yes thLocL57 thLoc "TH Splice Hover"
]
where yes, broken :: (TestTree -> Maybe TestTree)
yes = Just -- test should run and pass
Expand Down
16 changes: 15 additions & 1 deletion haskell-language-server.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,11 @@ flag pragmas
default: False
manual: True

flag splice
description: Enable splice plugin
default: False
manual: True

-- formatters

flag floskell
Expand Down Expand Up @@ -201,6 +206,11 @@ common pragmas
other-modules: Ide.Plugin.Pragmas
cpp-options: -Dpragmas

common splice
if flag(splice) || flag(all-plugins)
build-depends: hls-splice-plugin
cpp-options: -Dsplice

-- formatters

common floskell
Expand Down Expand Up @@ -251,6 +261,7 @@ executable haskell-language-server
, hlint
, moduleName
, pragmas
, splice
, floskell
, fourmolu
, ormolu
Expand Down Expand Up @@ -384,8 +395,9 @@ test-suite func-test
, tasty-ant-xml >=1.1.6
, tasty-golden
, tasty-rerun
, ghcide

hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test
hs-source-dirs: test/functional plugins/tactics/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src

main-is: Main.hs
other-modules:
Expand All @@ -410,6 +422,8 @@ test-suite func-test
Symbol
TypeDefinition
Tactic
Splice
Ide.Plugin.Splice.Types
Ide.Plugin.Tactic.TestTypes

ghc-options:
Expand Down
Loading

0 comments on commit 4a969a9

Please sign in to comment.