Splice Plugin: expands TH splices and QuasiQuotes

cabal.project

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

exe/Plugins.hs

@@ -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
@@ -120,6 +124,9 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins
 #endif
 #if hlint
       , Hlint.descriptor "hlint"
+#endif
+#if splice
+      , Splice.descriptor "splice"
 #endif
       ]
     examplePlugins =

ghcide/ghcide.cabal

@@ -46,6 +46,7 @@ library
         data-default,
         deepseq,
         directory,
+        dlist,
         extra,
         fuzzy,
         filepath,

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

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

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

@@ -3,6 +3,7 @@
 
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingStrategies #-}
 
@@ -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
@@ -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)
@@ -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
@@ -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

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

@@ -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.
@@ -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
 

ghcide/test/data/hover/GotoHover.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
 {- HLINT ignore -}
 module GotoHover ( module GotoHover) where
 import Data.Text (Text, pack)
@@ -56,5 +56,8 @@ outer = undefined inner where
 imported :: Bar
 imported = foo
 
+aa2 :: Bool
+aa2 = $(id [| True |])
+
 hole :: Int
 hole = _

ghcide/test/exe/Main.hs

@@ -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"
@@ -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
@@ -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

haskell-language-server.cabal

@@ -127,6 +127,11 @@ flag pragmas
   default:     False
   manual:      True
 
+flag splice
+  description: Enable splice plugin
+  default:     False
+  manual:      True
+
 -- formatters
 
 flag floskell
@@ -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
@@ -251,6 +261,7 @@ executable haskell-language-server
                     , hlint
                     , moduleName
                     , pragmas
+                    , splice
                     , floskell
                     , fourmolu
                     , ormolu
@@ -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:
@@ -410,6 +422,8 @@ test-suite func-test
     Symbol
     TypeDefinition
     Tactic
+    Splice
+    Ide.Plugin.Splice.Types
     Ide.Plugin.Tactic.TestTypes
 
   ghc-options: