Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighli…

…ght and scope-aware completions for local variables (#784) * Add GetHieAsts rule * hlint * fix build for 8.4 * Reimplement Hover/GotoDefn in terms of HIE Files. Implement Document Hightlight LSP request Add GetDocMap, GetHieFile rules. * Fix gotodef for record fields * Completion for locals * Don't need to hack cursor position because of fuzzy ranges * hlint * fix bench and warning on 8.10 * disable 8.4 CI jobs * Don't collect module level bindings * tweaks * Show kinds * docs * Defs for ModuleNames * Fix some tests * hlint * Mark remaining tests as broken * Add completion tests * add highlight tests * Fix HieAst for 8.6 * CPP away the unexpected success * More CPP hacks for 8.10 tests
haskell · Sep 27, 2020 · 62f4d06 · 62f4d06
1 parent 1cda5ed
commit 62f4d06
Show file tree

Hide file tree

Showing 26 changed files with 729 additions and 646 deletions.
diff --git a/.azure/linux-stack.yml b/.azure/linux-stack.yml
@@ -11,8 +11,6 @@ jobs:
         STACK_YAML: "stack88.yaml"
       stack_86:
         STACK_YAML: "stack.yaml"
-      stack_84:
-        STACK_YAML: "stack84.yaml"
       stack_ghc_lib_88:
         STACK_YAML: "stack-ghc-lib.yaml"
   variables:

diff --git a/.azure/windows-stack.yml b/.azure/windows-stack.yml
@@ -11,8 +11,6 @@ jobs:
         STACK_YAML: "stack88.yaml"
       stack_86:
         STACK_YAML: "stack.yaml"
-      stack_84:
-        STACK_YAML: "stack84.yaml"
       stack_ghc_lib_88:
         STACK_YAML: "stack-ghc-lib.yaml"
   variables:

diff --git a/.hlint.yaml b/.hlint.yaml
@@ -95,7 +95,7 @@
 - flags:
   - default: false
   - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]}
-  - {name: [-Wno-dodgy-imports], within: [Main, Development.IDE.GHC.Compat]}
+  - {name: [-Wno-dodgy-imports,-Wno-incomplete-uni-patterns], within: [Main, Development.IDE.GHC.Compat]}
 # - modules:
 #   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
 #   - {name: Control.Arrow, within: []} # Certain modules are banned entirely

diff --git a/ghcide.cabal b/ghcide.cabal
@@ -48,6 +48,7 @@ library
         extra,
         fuzzy,
         filepath,
+        fingertree,
         haddock-library >= 1.8,
         hashable,
         haskell-lsp-types == 0.22.*,
@@ -140,6 +141,8 @@ library
         Development.IDE.LSP.Protocol
         Development.IDE.LSP.Server
         Development.IDE.Spans.Common
+        Development.IDE.Spans.AtPoint
+        Development.IDE.Spans.LocalBindings
         Development.IDE.Types.Diagnostics
         Development.IDE.Types.Exports
         Development.IDE.Types.Location
@@ -173,10 +176,7 @@ library
         Development.IDE.GHC.WithDynFlags
         Development.IDE.Import.FindImports
         Development.IDE.LSP.Notifications
-        Development.IDE.Spans.AtPoint
-        Development.IDE.Spans.Calculate
         Development.IDE.Spans.Documentation
-        Development.IDE.Spans.Type
         Development.IDE.Plugin.CodeAction.PositionIndexed
         Development.IDE.Plugin.CodeAction.Rules
         Development.IDE.Plugin.CodeAction.RuleTypes

diff --git a/src-ghc810/Development/IDE/GHC/HieAst.hs b/src-ghc810/Development/IDE/GHC/HieAst.hs
@@ -17,7 +17,7 @@ Main functions for .hie file generation
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-module Development.IDE.GHC.HieAst ( mkHieFile ) where
+module Development.IDE.GHC.HieAst ( mkHieFile, enrichHie ) where
 
 import GhcPrelude
 
@@ -34,7 +34,7 @@ import GHC.Hs
 import HscTypes
 import Module                     ( ModuleName, ml_hs_file )
 import MonadUtils                 ( concatMapM, liftIO )
-import Name                       ( Name, nameSrcSpan, setNameLoc )
+import Name                       ( Name, nameSrcSpan )
 import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
 import SrcLoc
 import TcHsSyn                    ( hsLitType, hsPatType )
@@ -1131,28 +1131,25 @@ instance ( ToHie (RFContext (Located label))
       , toHie expr
       ]
 
-removeDefSrcSpan :: Name -> Name
-removeDefSrcSpan n = setNameLoc n noSrcSpan
-
 instance ToHie (RFContext (LFieldOcc GhcRn)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc name _ ->
-      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+      [ toHie $ C (RecField c rhs) (L nspan name)
       ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (LFieldOcc GhcTc)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous name _ ->
-      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+      [ toHie $ C (RecField c rhs) $ L nspan name
       ]
     Ambiguous _name _ ->
       [ ]
@@ -1161,11 +1158,11 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     Ambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XAmbiguousFieldOcc _ -> []

diff --git a/src-ghc86/Development/IDE/GHC/HieAst.hs b/src-ghc86/Development/IDE/GHC/HieAst.hs
@@ -17,7 +17,7 @@ Main functions for .hie file generation
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DataKinds #-}
-module Development.IDE.GHC.HieAst ( mkHieFile ) where
+module Development.IDE.GHC.HieAst ( mkHieFile, enrichHie ) where
 
 import Avail                      ( Avails )
 import Bag                        ( Bag, bagToList )
@@ -32,7 +32,7 @@ import HsSyn
 import HscTypes
 import Module                     ( ModuleName, ml_hs_file )
 import MonadUtils                 ( concatMapM, liftIO )
-import Name                       ( Name, nameSrcSpan, setNameLoc )
+import Name                       ( Name, nameSrcSpan )
 import SrcLoc
 import TcHsSyn                    ( hsLitType, hsPatType )
 import Type                       ( mkFunTys, Type )
@@ -739,6 +739,8 @@ instance ( a ~ GhcPass p
          , ToHie (RScoped (LHsLocalBinds a))
          , ToHie (TScoped (LHsWcType (NoGhcTc a)))
          , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
+         , ToHie (TScoped (XExprWithTySig (GhcPass p)))
+         , ToHie (TScoped (XAppTypeE (GhcPass p)))
          , Data (HsExpr a)
          , Data (HsSplice a)
          , Data (HsTupArg a)
@@ -771,9 +773,9 @@ instance ( a ~ GhcPass p
         [ toHie a
         , toHie b
         ]
-      HsAppType _sig expr ->
+      HsAppType sig expr ->
         [ toHie expr
-        -- , toHie $ TS (ResolvedScopes []) sig
+        , toHie $ TS (ResolvedScopes []) sig
         ]
       OpApp _ a b c ->
         [ toHie a
@@ -831,9 +833,9 @@ instance ( a ~ GhcPass p
         [ toHie expr
         , toHie $ map (RC RecFieldAssign) upds
         ]
-      ExprWithTySig _ expr ->
+      ExprWithTySig sig expr ->
         [ toHie expr
-        -- , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
+        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
         ]
       ArithSeq _ _ info ->
         [ toHie info
@@ -1006,28 +1008,25 @@ instance ( ToHie (RFContext (Located label))
       , toHie expr
       ]
 
-removeDefSrcSpan :: Name -> Name
-removeDefSrcSpan n = setNameLoc n noSrcSpan
-
 instance ToHie (RFContext (LFieldOcc GhcRn)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc name _ ->
-      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+      [ toHie $ C (RecField c rhs) (L nspan name)
       ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (LFieldOcc GhcTc)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous name _ ->
-      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+      [ toHie $ C (RecField c rhs) $ L nspan name
       ]
     Ambiguous _name _ ->
       [ ]
@@ -1036,11 +1035,11 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     Ambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XAmbiguousFieldOcc _ -> []

diff --git a/src-ghc88/Development/IDE/GHC/HieAst.hs b/src-ghc88/Development/IDE/GHC/HieAst.hs
@@ -16,7 +16,7 @@ Main functions for .hie file generation
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-module Development.IDE.GHC.HieAst ( mkHieFile ) where
+module Development.IDE.GHC.HieAst ( mkHieFile, enrichHie ) where
 
 import Avail                      ( Avails )
 import Bag                        ( Bag, bagToList )
@@ -31,7 +31,7 @@ import HsSyn
 import HscTypes
 import Module                     ( ModuleName, ml_hs_file )
 import MonadUtils                 ( concatMapM, liftIO )
-import Name                       ( Name, nameSrcSpan, setNameLoc )
+import Name                       ( Name, nameSrcSpan )
 import SrcLoc
 import TcHsSyn                    ( hsLitType, hsPatType )
 import Type                       ( mkFunTys, Type )
@@ -998,28 +998,25 @@ instance ( ToHie (RFContext (Located label))
       , toHie expr
       ]
 
-removeDefSrcSpan :: Name -> Name
-removeDefSrcSpan n = setNameLoc n noSrcSpan
-
 instance ToHie (RFContext (LFieldOcc GhcRn)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc name _ ->
-      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+      [ toHie $ C (RecField c rhs) (L nspan name)
       ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (LFieldOcc GhcTc)) where
   toHie (RFC c rhs (L nspan f)) = concatM $ case f of
     FieldOcc var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XFieldOcc _ -> []
 
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous name _ ->
-      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+      [ toHie $ C (RecField c rhs) $ L nspan name
       ]
     Ambiguous _name _ ->
       [ ]
@@ -1028,11 +1025,11 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
 instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
   toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
     Unambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     Ambiguous var _ ->
-      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      let var' = setVarName var (varName var)
       in [ toHie $ C (RecField c rhs) (L nspan var')
          ]
     XAmbiguousFieldOcc _ -> []

diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs
@@ -18,7 +18,8 @@ module Development.IDE.Core.Compile
   , addRelativeImport
   , mkTcModuleResult
   , generateByteCode
-  , generateAndWriteHieFile
+  , generateHieAsts
+  , writeHieFile
   , writeHiFile
   , getModSummaryFromImports
   , loadHieFile
@@ -56,7 +57,7 @@ import ErrUtils
 #endif
 
 import           Finder
-import           Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
+import           Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile)
 import qualified Development.IDE.GHC.Compat     as GHC
 import qualified Development.IDE.GHC.Compat     as Compat
 import           GhcMonad
@@ -65,7 +66,7 @@ import qualified HeaderInfo                     as Hdr
 import           HscMain                        (hscInteractive, hscSimplify)
 import           MkIface
 import           StringBuffer                   as SB
-import           TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins)
+import           TcRnMonad (tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds)
 import           TcIface                        (typecheckIface)
 import           TidyPgm
 
@@ -320,7 +321,7 @@ mkTcModuleResult tcm upgradedError = do
     (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
 #endif
     let mod_info = HomeModInfo iface details Nothing
-    return $ TcModuleResult tcm mod_info upgradedError
+    return $ TcModuleResult tcm mod_info upgradedError Nothing
   where
     (tcGblEnv, details) = tm_internals_ tcm
 
@@ -331,19 +332,25 @@ atomicFileWrite targetPath write = do
   (tempFilePath, cleanUp) <- newTempFileWithin dir
   (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
 
-generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> BS.ByteString -> IO [FileDiagnostic]
-generateAndWriteHieFile hscEnv tcm source =
-  handleGenerationErrors dflags "extended interface generation" $ do
+generateHieAsts :: HscEnv -> TypecheckedModule -> IO ([FileDiagnostic], Maybe (HieASTs Type))
+generateHieAsts hscEnv tcm =
+  handleGenerationErrors' dflags "extended interface generation" $ do
     case tm_renamed_source tcm of
-      Just rnsrc -> do
-        hf <- runHsc hscEnv $
-          GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc source
-        atomicFileWrite targetPath $ flip GHC.writeHieFile hf
+      Just rnsrc -> runHsc hscEnv $
+        Just <$> GHC.enrichHie (tcg_binds $ fst $ tm_internals_ tcm) rnsrc
       _ ->
-        return ()
+        return Nothing
+  where
+    dflags       = hsc_dflags hscEnv
+
+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
+    hf <- runHsc hscEnv $
+      GHC.mkHieFile' mod_summary exports ast source
+    atomicFileWrite targetPath $ flip GHC.writeHieFile hf
   where
     dflags       = hsc_dflags hscEnv
-    mod_summary  = pm_mod_summary $ tm_parsed_module tcm
     mod_location = ms_location mod_summary
     targetPath   = Compat.ml_hie_file mod_location
 
@@ -365,6 +372,14 @@ handleGenerationErrors dflags source action =
     . (("Error during " ++ T.unpack source) ++) . show @SomeException
     ]
 
+handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
+handleGenerationErrors' dflags source action =
+  fmap ([],) action `catches`
+    [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
+    , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "<internal>")
+    . (("Error during " ++ T.unpack source) ++) . show @SomeException
+    ]
+
 
 -- | Setup the environment that GHC needs according to our
 -- best understanding (!)