mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight 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
This commit is contained in:
parent
1cda5edf0d
commit
62f4d0644a
@ -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:
|
||||
|
@ -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:
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,20 +1131,17 @@ 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 _ -> []
|
||||
@ -1152,7 +1149,7 @@ instance ToHie (RFContext (LFieldOcc GhcTc)) where
|
||||
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 _ -> []
|
||||
|
@ -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,20 +1008,17 @@ 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 _ -> []
|
||||
@ -1027,7 +1026,7 @@ instance ToHie (RFContext (LFieldOcc GhcTc)) where
|
||||
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 _ -> []
|
||||
|
@ -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,20 +998,17 @@ 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 _ -> []
|
||||
@ -1019,7 +1016,7 @@ instance ToHie (RFContext (LFieldOcc GhcTc)) where
|
||||
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 _ -> []
|
||||
|
@ -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 (!)
|
||||
|
@ -74,7 +74,6 @@ toCurrentPosition (PositionMapping pm) = positionResultToMaybe . toDelta pm
|
||||
-- a specific version
|
||||
newtype PositionMapping = PositionMapping PositionDelta
|
||||
|
||||
|
||||
toCurrentRange :: PositionMapping -> Range -> Maybe Range
|
||||
toCurrentRange mapping (Range a b) =
|
||||
Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
|
||||
@ -121,7 +120,7 @@ toCurrent (Range start@(Position startLine startColumn) end@(Position endLine en
|
||||
| line > endLine || line == endLine && column >= endColumn =
|
||||
-- Position is after the change so increase line and column number
|
||||
-- as necessary.
|
||||
PositionExact $ Position newLine newColumn
|
||||
PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn
|
||||
| otherwise = PositionRange start end
|
||||
-- Position is in the region that was changed.
|
||||
where
|
||||
@ -131,10 +130,10 @@ toCurrent (Range start@(Position startLine startColumn) end@(Position endLine en
|
||||
newEndColumn
|
||||
| linesNew == 0 = startColumn + T.length t
|
||||
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t
|
||||
!newColumn
|
||||
newColumn
|
||||
| line == endLine = column + newEndColumn - endColumn
|
||||
| otherwise = column
|
||||
!newLine = line + lineDiff
|
||||
newLine = line + lineDiff
|
||||
|
||||
fromCurrent :: Range -> T.Text -> Position -> PositionResult Position
|
||||
fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine endColumn)) t (Position line column)
|
||||
@ -144,7 +143,7 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine
|
||||
| line > newEndLine || line == newEndLine && column >= newEndColumn =
|
||||
-- Position is after the change so increase line and column number
|
||||
-- as necessary.
|
||||
PositionExact $ Position newLine newColumn
|
||||
PositionExact $ newLine `seq` newColumn `seq` Position newLine newColumn
|
||||
| otherwise = PositionRange start end
|
||||
-- Position is in the region that was changed.
|
||||
where
|
||||
@ -155,7 +154,7 @@ fromCurrent (Range start@(Position startLine startColumn) end@(Position endLine
|
||||
newEndColumn
|
||||
| linesNew == 0 = startColumn + T.length t
|
||||
| otherwise = T.length $ T.takeWhileEnd (/= '\n') t
|
||||
!newColumn
|
||||
newColumn
|
||||
| line == newEndLine = column - (newEndColumn - endColumn)
|
||||
| otherwise = column
|
||||
!newLine = line - lineDiff
|
||||
newLine = line - lineDiff
|
||||
|
@ -15,22 +15,24 @@ import Control.DeepSeq
|
||||
import Data.Aeson.Types (Value)
|
||||
import Data.Binary
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Compat hiding (HieFileResult)
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.Core.Shake (KnownTargets)
|
||||
import Data.Hashable
|
||||
import Data.Typeable
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import Development.Shake
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Module (InstalledUnitId)
|
||||
import HscTypes (hm_iface, CgGuts, Linkable, HomeModInfo, ModDetails)
|
||||
|
||||
import Development.IDE.Spans.Type
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Spans.LocalBindings
|
||||
import Development.IDE.Import.FindImports (ArtifactsLocation)
|
||||
import Data.ByteString (ByteString)
|
||||
|
||||
import Language.Haskell.LSP.Types (NormalizedFilePath)
|
||||
|
||||
-- NOTATION
|
||||
-- Foo+ means Foo for the dependencies
|
||||
@ -66,6 +68,7 @@ data TcModuleResult = TcModuleResult
|
||||
-- HomeModInfo instead
|
||||
, tmrModInfo :: HomeModInfo
|
||||
, tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module?
|
||||
, tmrHieAsts :: !(Maybe (HieASTs Type)) -- ^ The HieASTs if we computed them
|
||||
}
|
||||
instance Show TcModuleResult where
|
||||
show = show . pm_mod_summary . tm_parsed_module . tmrModule
|
||||
@ -98,11 +101,38 @@ instance NFData HiFileResult where
|
||||
instance Show HiFileResult where
|
||||
show = show . hirModSummary
|
||||
|
||||
-- | Save the uncompressed AST here, we compress it just before writing to disk
|
||||
data HieAstResult
|
||||
= HAR
|
||||
{ hieModule :: Module
|
||||
, hieAst :: !(HieASTs Type)
|
||||
, refMap :: !RefMap
|
||||
, importMap :: !(M.Map ModuleName NormalizedFilePath) -- ^ Where are the modules imported by this file located?
|
||||
}
|
||||
|
||||
instance NFData HieAstResult where
|
||||
rnf (HAR m hf rm im) = rnf m `seq` rwhnf hf `seq` rnf rm `seq` rnf im
|
||||
|
||||
instance Show HieAstResult where
|
||||
show = show . hieModule
|
||||
|
||||
-- | The type checked version of this file, requires TypeCheck+
|
||||
type instance RuleResult TypeCheck = TcModuleResult
|
||||
|
||||
-- | Information about what spans occur where, requires TypeCheck
|
||||
type instance RuleResult GetSpanInfo = SpansInfo
|
||||
-- | The uncompressed HieAST
|
||||
type instance RuleResult GetHieAst = HieAstResult
|
||||
|
||||
-- | A IntervalMap telling us what is in scope at each point
|
||||
type instance RuleResult GetBindings = Bindings
|
||||
|
||||
data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap}
|
||||
instance NFData DocAndKindMap where
|
||||
rnf (DKMap a b) = rnf a `seq` rnf b
|
||||
|
||||
instance Show DocAndKindMap where
|
||||
show = const "docmap"
|
||||
|
||||
type instance RuleResult GetDocMap = DocAndKindMap
|
||||
|
||||
-- | Convert to Core, requires TypeCheck*
|
||||
type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
|
||||
@ -196,11 +226,23 @@ instance Hashable TypeCheck
|
||||
instance NFData TypeCheck
|
||||
instance Binary TypeCheck
|
||||
|
||||
data GetSpanInfo = GetSpanInfo
|
||||
data GetDocMap = GetDocMap
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetSpanInfo
|
||||
instance NFData GetSpanInfo
|
||||
instance Binary GetSpanInfo
|
||||
instance Hashable GetDocMap
|
||||
instance NFData GetDocMap
|
||||
instance Binary GetDocMap
|
||||
|
||||
data GetHieAst = GetHieAst
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetHieAst
|
||||
instance NFData GetHieAst
|
||||
instance Binary GetHieAst
|
||||
|
||||
data GetBindings = GetBindings
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
instance Hashable GetBindings
|
||||
instance NFData GetBindings
|
||||
instance Binary GetBindings
|
||||
|
||||
data GenerateCore = GenerateCore
|
||||
deriving (Eq, Show, Typeable, Generic)
|
||||
@ -262,4 +304,4 @@ instance Hashable GetClientSettings
|
||||
instance NFData GetClientSettings
|
||||
instance Binary GetClientSettings
|
||||
|
||||
type instance RuleResult GetClientSettings = Hashed (Maybe Value)
|
||||
type instance RuleResult GetClientSettings = Hashed (Maybe Value)
|
||||
|
@ -24,6 +24,7 @@ module Development.IDE.Core.Rules(
|
||||
getAtPoint,
|
||||
getDefinition,
|
||||
getTypeDefinition,
|
||||
highlightAtPoint,
|
||||
getDependencies,
|
||||
getParsedModule,
|
||||
generateCore,
|
||||
@ -39,14 +40,15 @@ import Control.Monad.Trans.Maybe
|
||||
import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.OfInterest
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Spans.Calculate
|
||||
import Development.IDE.Spans.Documentation
|
||||
import Development.IDE.Spans.LocalBindings
|
||||
import Development.IDE.Import.DependencyInformation
|
||||
import Development.IDE.Import.FindImports
|
||||
import Development.IDE.Core.FileExists
|
||||
import Development.IDE.Core.FileStore (modificationTime, getFileContents)
|
||||
import Development.IDE.Types.Diagnostics as Diag
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, TargetModule, TargetFile)
|
||||
import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile)
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.GHC.WithDynFlags
|
||||
import Data.Either.Extra
|
||||
@ -57,14 +59,15 @@ import qualified Data.IntMap.Strict as IntMap
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.List
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.Shake hiding (Diagnostic)
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import Development.IDE.Spans.Type
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Language.Haskell.LSP.Types (DocumentHighlight (..))
|
||||
|
||||
import qualified GHC.LanguageExtensions as LangExt
|
||||
import HscTypes hiding (TargetModule, TargetFile)
|
||||
@ -134,26 +137,35 @@ getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [
|
||||
getAtPoint file pos = fmap join $ runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans, mapping) <- useE GetSpanInfo file
|
||||
|
||||
(hieAst -> hf, mapping) <- useE GetHieAst file
|
||||
dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> (runMaybeT $ useE GetDocMap file)
|
||||
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
return $ AtPoint.atPoint opts spans pos'
|
||||
return $ AtPoint.atPoint opts hf dkMap pos'
|
||||
|
||||
-- | Goto Definition.
|
||||
getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
|
||||
getDefinition file pos = runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans,mapping) <- useE GetSpanInfo file
|
||||
(HAR _ hf _ imports, mapping) <- useE GetHieAst file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos'
|
||||
AtPoint.gotoDefinition (getHieFile ide file) opts imports hf pos'
|
||||
|
||||
getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
|
||||
getTypeDefinition file pos = runMaybeT $ do
|
||||
ide <- ask
|
||||
opts <- liftIO $ getIdeOptionsIO ide
|
||||
(spans,mapping) <- useE GetSpanInfo file
|
||||
(hieAst -> hf, mapping) <- useE GetHieAst file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos'
|
||||
AtPoint.gotoTypeDefinition (getHieFile ide file) opts hf pos'
|
||||
|
||||
highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
|
||||
highlightAtPoint file pos = runMaybeT $ do
|
||||
(HAR _ hf rf _,mapping) <- useE GetHieAst file
|
||||
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
|
||||
AtPoint.documentHighlight hf rf pos'
|
||||
|
||||
getHieFile
|
||||
:: ShakeExtras
|
||||
@ -507,27 +519,51 @@ getDependenciesRule =
|
||||
let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
|
||||
return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, ([], transitiveDeps depInfo file))
|
||||
|
||||
-- Source SpanInfo is used by AtPoint and Goto Definition.
|
||||
getSpanInfoRule :: Rules ()
|
||||
getSpanInfoRule =
|
||||
define $ \GetSpanInfo file -> do
|
||||
tc <- use_ TypeCheck file
|
||||
packageState <- hscEnv <$> use_ GhcSessionDeps file
|
||||
getHieAstsRule :: Rules ()
|
||||
getHieAstsRule =
|
||||
define $ \GetHieAst f -> do
|
||||
tmr <- use_ TypeCheck f
|
||||
(diags,masts) <- case tmrHieAsts tmr of
|
||||
-- If we already have them from typechecking, return them
|
||||
Just asts -> pure ([], Just asts)
|
||||
-- Compute asts if we haven't already computed them
|
||||
Nothing -> do
|
||||
hsc <- hscEnv <$> use_ GhcSession f
|
||||
(diagsHieGen, masts) <- liftIO $ generateHieAsts hsc (tmrModule tmr)
|
||||
pure (diagsHieGen, masts)
|
||||
let refmap = generateReferencesMap . getAsts <$> masts
|
||||
im <- use GetLocatedImports f
|
||||
let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports
|
||||
pure (diags, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> fmap mkImports im)
|
||||
|
||||
getBindingsRule :: Rules ()
|
||||
getBindingsRule =
|
||||
define $ \GetBindings f -> do
|
||||
har <- use_ GetHieAst f
|
||||
pure ([], Just $ bindings $ refMap har)
|
||||
|
||||
getDocMapRule :: Rules ()
|
||||
getDocMapRule =
|
||||
define $ \GetDocMap file -> do
|
||||
hmi <- hirModIface <$> use_ GetModIface file
|
||||
hsc <- hscEnv <$> use_ GhcSessionDeps file
|
||||
(refMap -> rf) <- use_ GetHieAst file
|
||||
|
||||
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
|
||||
let tdeps = transitiveModuleDeps deps
|
||||
|
||||
-- When possible, rely on the haddocks embedded in our interface files
|
||||
-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
|
||||
#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
|
||||
let parsedDeps = []
|
||||
let parsedDeps = []
|
||||
#else
|
||||
deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
|
||||
let tdeps = transitiveModuleDeps deps
|
||||
parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule tdeps
|
||||
parsedDeps <- uses_ GetParsedModule tdeps
|
||||
#endif
|
||||
|
||||
(fileImports, _) <- use_ GetLocatedImports file
|
||||
let imports = second (fmap artifactFilePath) <$> fileImports
|
||||
x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
|
||||
return ([], Just x)
|
||||
ifaces <- uses_ GetModIface tdeps
|
||||
|
||||
dkMap <- liftIO $ evalGhcEnv hsc $ mkDocMap parsedDeps rf hmi (map hirModIface ifaces)
|
||||
return ([],Just dkMap)
|
||||
|
||||
-- Typechecks a module.
|
||||
typeCheckRule :: Rules ()
|
||||
@ -573,14 +609,20 @@ typeCheckRuleDefinition hsc pm isFoi source = do
|
||||
case isFoi of
|
||||
IsFOI Modified -> return (diags, Just tcm)
|
||||
_ -> do -- If the file is saved on disk, or is not a FOI, we write out ifaces
|
||||
diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm) (fromMaybe "" source)
|
||||
let tm = tmrModule tcm
|
||||
ms = tmrModSummary tcm
|
||||
exports = tcg_exports $ fst $ tm_internals_ tm
|
||||
(diagsHieGen, masts) <- generateHieAsts hsc (tmrModule tcm)
|
||||
diagsHieWrite <- case masts of
|
||||
Nothing -> pure mempty
|
||||
Just asts -> writeHieFile hsc ms exports asts $ fromMaybe "" source
|
||||
-- Don't save interface files for modules that compiled due to defering
|
||||
-- type errors, as we won't get proper diagnostics if we load these from
|
||||
-- disk
|
||||
diagsHi <- if not $ tmrDeferedError tcm
|
||||
then writeHiFile hsc tcm
|
||||
else pure mempty
|
||||
return (diags <> diagsHi <> diagsHie, Just tcm)
|
||||
return (diags <> diagsHi <> diagsHieGen <> diagsHieWrite, Just tcm{tmrHieAsts = masts})
|
||||
(diags, res) ->
|
||||
return (diags, snd <$> res)
|
||||
where
|
||||
@ -849,7 +891,7 @@ mainRule = do
|
||||
reportImportCyclesRule
|
||||
getDependenciesRule
|
||||
typeCheckRule
|
||||
getSpanInfoRule
|
||||
getDocMapRule
|
||||
generateCoreRule
|
||||
generateByteCodeRule
|
||||
loadGhcSession
|
||||
@ -860,6 +902,8 @@ mainRule = do
|
||||
getModuleGraphRule
|
||||
knownFilesRule
|
||||
getClientSettingsRule
|
||||
getHieAstsRule
|
||||
getBindingsRule
|
||||
|
||||
-- | Given the path to a module src file, this rule returns True if the
|
||||
-- corresponding `.hi` file is stable, that is, if it is newer
|
||||
|
@ -5,7 +5,7 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# OPTIONS -Wno-dodgy-imports #-}
|
||||
{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-}
|
||||
#include "ghc-api-version.h"
|
||||
|
||||
-- | Attempt at hiding the GHC version differences we can.
|
||||
@ -16,6 +16,9 @@ module Development.IDE.GHC.Compat(
|
||||
NameCacheUpdater(..),
|
||||
hieExportNames,
|
||||
mkHieFile,
|
||||
mkHieFile',
|
||||
enrichHie,
|
||||
RefMap,
|
||||
writeHieFile,
|
||||
readHieFile,
|
||||
supportsHieFiles,
|
||||
@ -55,6 +58,15 @@ module Development.IDE.GHC.Compat(
|
||||
upNameCache,
|
||||
disableWarningsAsErrors,
|
||||
fixDetailsForTH,
|
||||
AvailInfo,
|
||||
tcg_exports,
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
module GHC.Hs.Extension,
|
||||
#else
|
||||
module HsExtension,
|
||||
noExtField,
|
||||
#endif
|
||||
|
||||
module GHC,
|
||||
initializePlugins,
|
||||
@ -69,6 +81,11 @@ module Development.IDE.GHC.Compat(
|
||||
module Development.IDE.GHC.HieUtils,
|
||||
#endif
|
||||
|
||||
#else
|
||||
HieASTs,
|
||||
getAsts,
|
||||
generateReferencesMap,
|
||||
|
||||
#endif
|
||||
) where
|
||||
|
||||
@ -81,6 +98,15 @@ import Packages
|
||||
import Data.IORef
|
||||
import HscTypes
|
||||
import NameCache
|
||||
import qualified Data.ByteString as BS
|
||||
import MkIface
|
||||
import TcRnTypes
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
import GHC.Hs.Extension
|
||||
#else
|
||||
import HsExtension
|
||||
#endif
|
||||
|
||||
import qualified GHC
|
||||
import GHC hiding (
|
||||
@ -120,13 +146,12 @@ import InstEnv (tidyClsInstDFun)
|
||||
import PatSyn (PatSyn, tidyPatSynIds)
|
||||
#endif
|
||||
|
||||
import TcRnTypes
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
import Development.IDE.GHC.HieAst (mkHieFile)
|
||||
import Development.IDE.GHC.HieAst (mkHieFile,enrichHie)
|
||||
import Development.IDE.GHC.HieBin
|
||||
import qualified DynamicLoading
|
||||
import Plugins (Plugin(parsedResultAction), withPlugins)
|
||||
import Data.Map.Strict (Map)
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
import HieUtils
|
||||
@ -153,7 +178,6 @@ import IfaceEnv
|
||||
import Binary
|
||||
import Data.ByteString (ByteString)
|
||||
import GhcPlugins (Hsc, srcErrorMessages, Unfolding(BootUnfolding), setIdUnfolding, tidyTopType, setIdType, globaliseId, isWiredInName, elemNameSet, idName, filterOut)
|
||||
import MkIface
|
||||
#endif
|
||||
|
||||
import Control.Exception (catch)
|
||||
@ -168,6 +192,12 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
|
||||
|
||||
#endif
|
||||
|
||||
#if !MIN_GHC_API_VERSION(8,10,0)
|
||||
noExtField :: NoExt
|
||||
noExtField = noExt
|
||||
#endif
|
||||
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
supportsHieFiles :: Bool
|
||||
supportsHieFiles = True
|
||||
@ -198,6 +228,49 @@ includePathsQuote = const []
|
||||
#endif
|
||||
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
type RefMap = Map Identifier [(Span, IdentifierDetails Type)]
|
||||
|
||||
mkHieFile' :: ModSummary
|
||||
-> [AvailInfo]
|
||||
-> HieASTs Type
|
||||
-> BS.ByteString
|
||||
-> Hsc HieFile
|
||||
mkHieFile' ms exports asts src = do
|
||||
let Just src_file = ml_hs_file $ ms_location ms
|
||||
(asts',arr) = compressTypes asts
|
||||
return $ HieFile
|
||||
{ hie_hs_file = src_file
|
||||
, hie_module = ms_mod ms
|
||||
, hie_types = arr
|
||||
, hie_asts = asts'
|
||||
-- mkIfaceExports sorts the AvailInfos for stability
|
||||
, hie_exports = mkIfaceExports exports
|
||||
, hie_hs_src = src
|
||||
}
|
||||
#else
|
||||
type RefMap = ()
|
||||
type HieASTs a = ()
|
||||
|
||||
mkHieFile' :: ModSummary
|
||||
-> [AvailInfo]
|
||||
-> HieASTs Type
|
||||
-> BS.ByteString
|
||||
-> Hsc HieFile
|
||||
mkHieFile' ms exports _ _ = return (HieFile (ms_mod ms) es)
|
||||
where
|
||||
es = nameListFromAvails (mkIfaceExports exports)
|
||||
|
||||
enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
|
||||
enrichHie _ _ = pure ()
|
||||
|
||||
getAsts :: HieASTs Type -> ()
|
||||
getAsts = id
|
||||
|
||||
generateReferencesMap :: () -> RefMap
|
||||
generateReferencesMap = id
|
||||
#endif
|
||||
|
||||
addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
|
||||
|
@ -14,6 +14,7 @@ module Development.IDE.GHC.Error
|
||||
, srcSpanToLocation
|
||||
, srcSpanToRange
|
||||
, realSrcSpanToRange
|
||||
, realSrcLocToPosition
|
||||
, srcSpanToFilename
|
||||
, zeroSpan
|
||||
, realSpan
|
||||
@ -72,8 +73,12 @@ srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real
|
||||
|
||||
realSrcSpanToRange :: RealSrcSpan -> Range
|
||||
realSrcSpanToRange real =
|
||||
Range (Position (srcSpanStartLine real - 1) (srcSpanStartCol real - 1))
|
||||
(Position (srcSpanEndLine real - 1) (srcSpanEndCol real - 1))
|
||||
Range (realSrcLocToPosition $ realSrcSpanStart real)
|
||||
(realSrcLocToPosition $ realSrcSpanEnd real)
|
||||
|
||||
realSrcLocToPosition :: RealSrcLoc -> Position
|
||||
realSrcLocToPosition real =
|
||||
Position (srcLocLine real - 1) (srcLocCol real - 1)
|
||||
|
||||
-- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones)
|
||||
-- FIXME This may not be an _absolute_ file name, needs fixing.
|
||||
|
@ -17,6 +17,7 @@ import qualified StringBuffer as SB
|
||||
import Control.DeepSeq
|
||||
import Data.Hashable
|
||||
import Development.IDE.GHC.Util
|
||||
import Bag
|
||||
|
||||
|
||||
-- Orphan instances for types from the GHC API.
|
||||
@ -80,3 +81,21 @@ instance Show ModuleName where
|
||||
show = moduleNameString
|
||||
instance Hashable ModuleName where
|
||||
hashWithSalt salt = hashWithSalt salt . show
|
||||
|
||||
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
instance NFData a => NFData (IdentifierDetails a) where
|
||||
rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b)
|
||||
|
||||
instance NFData RealSrcSpan where
|
||||
rnf = rwhnf
|
||||
|
||||
instance NFData Type where
|
||||
rnf = rwhnf
|
||||
#endif
|
||||
|
||||
instance Show a => Show (Bag a) where
|
||||
show = show . bagToList
|
||||
|
||||
instance NFData HsDocString where
|
||||
rnf = rwhnf
|
||||
|
@ -7,6 +7,7 @@ module Development.IDE.LSP.HoverDefinition
|
||||
( setHandlersHover
|
||||
, setHandlersDefinition
|
||||
, setHandlersTypeDefinition
|
||||
, setHandlersDocHighlight
|
||||
-- * For haskell-language-server
|
||||
, hover
|
||||
, gotoDefinition
|
||||
@ -27,21 +28,25 @@ import qualified Data.Text as T
|
||||
gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
|
||||
hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
|
||||
gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
|
||||
documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))
|
||||
gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
|
||||
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc
|
||||
hover = request "Hover" getAtPoint Nothing foundHover
|
||||
documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
|
||||
|
||||
foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
|
||||
foundHover (mbRange, contents) =
|
||||
Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
|
||||
|
||||
setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition :: PartialHandlers c
|
||||
setHandlersDefinition, setHandlersHover, setHandlersTypeDefinition, setHandlersDocHighlight :: PartialHandlers c
|
||||
setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
|
||||
setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}
|
||||
setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.hoverHandler = withResponse RspHover $ const hover}
|
||||
setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->
|
||||
return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}
|
||||
|
||||
-- | Respond to and log a hover or go-to-definition request
|
||||
request
|
||||
|
@ -106,6 +106,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
|
||||
initializeRequestHandler <>
|
||||
setHandlersIgnore <> -- least important
|
||||
setHandlersDefinition <> setHandlersHover <> setHandlersTypeDefinition <>
|
||||
setHandlersDocHighlight <>
|
||||
setHandlersOutline <>
|
||||
userHandlers <>
|
||||
setHandlersNotifications <> -- absolutely critical, join them with user notifications
|
||||
|
@ -8,7 +8,6 @@ module Development.IDE.Plugin.Completions
|
||||
, getCompletionsLSP
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Language.Haskell.LSP.Messages
|
||||
import Language.Haskell.LSP.Types
|
||||
import qualified Language.Haskell.LSP.Core as LSP
|
||||
@ -20,6 +19,7 @@ import GHC.Generics
|
||||
|
||||
import Development.IDE.Plugin
|
||||
import Development.IDE.Core.Service
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Plugin.Completions.Logic
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Options
|
||||
@ -42,7 +42,6 @@ import Development.IDE.Import.DependencyInformation
|
||||
plugin :: Plugin c
|
||||
plugin = Plugin produceCompletions setHandlersCompletion
|
||||
|
||||
|
||||
produceCompletions :: Rules ()
|
||||
produceCompletions = do
|
||||
define $ \ProduceCompletions file -> do
|
||||
@ -127,10 +126,9 @@ instance Hashable NonLocalCompletions
|
||||
instance NFData NonLocalCompletions
|
||||
instance Binary NonLocalCompletions
|
||||
|
||||
|
||||
-- | Generate code actions.
|
||||
getCompletionsLSP
|
||||
:: LSP.LspFuncs c
|
||||
:: LSP.LspFuncs cofd
|
||||
-> IdeState
|
||||
-> CompletionParams
|
||||
-> IO (Either ResponseError CompletionResponseResult)
|
||||
@ -146,9 +144,10 @@ getCompletionsLSP lsp ide
|
||||
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
|
||||
compls <- useWithStaleFast ProduceCompletions npath
|
||||
pm <- useWithStaleFast GetParsedModule npath
|
||||
pure (opts, liftA2 (,) compls pm)
|
||||
binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath
|
||||
pure (opts, fmap (,pm,binds) compls )
|
||||
case compls of
|
||||
Just ((cci', _), (pm, mapping)) -> do
|
||||
Just ((cci', _), parsedMod, bindMap) -> do
|
||||
pfix <- VFS.getCompletionPrefix position cnts
|
||||
case (pfix, completionContext) of
|
||||
(Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
|
||||
@ -156,7 +155,7 @@ getCompletionsLSP lsp ide
|
||||
(Just pfix', _) -> do
|
||||
-- TODO pass the real capabilities here (or remove the logic for snippets)
|
||||
let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
|
||||
Completions . List <$> getCompletions ideOpts cci' pm mapping pfix' fakeClientCapabilities (WithSnippets True)
|
||||
Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' fakeClientCapabilities (WithSnippets True)
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
_ -> return (Completions $ List [])
|
||||
|
@ -10,7 +10,7 @@ module Development.IDE.Plugin.Completions.Logic (
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Char (isSpace, isUpper)
|
||||
import Data.Char (isUpper)
|
||||
import Data.Generics
|
||||
import Data.List.Extra as List hiding (stripPrefix)
|
||||
import qualified Data.Map as Map
|
||||
@ -41,6 +41,7 @@ import Development.IDE.Core.Compile
|
||||
import Development.IDE.Core.PositionMapping
|
||||
import Development.IDE.Plugin.Completions.Types
|
||||
import Development.IDE.Spans.Documentation
|
||||
import Development.IDE.Spans.LocalBindings
|
||||
import Development.IDE.GHC.Compat as GHC
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Types.Options
|
||||
@ -147,14 +148,17 @@ mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs}
|
||||
Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
|
||||
Nothing Nothing Nothing Nothing Nothing
|
||||
where kind = Just compKind
|
||||
docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs
|
||||
docs' = imported : spanDocToMarkdown docs
|
||||
imported = case importedFrom of
|
||||
Left pos -> "*Defined at '" <> ppr pos <> "'*\n'"
|
||||
Right mod -> "*Defined in '" <> mod <> "'*\n"
|
||||
colon = if optNewColonConvention then ": " else ":: "
|
||||
|
||||
mkNameCompItem :: Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> CompItem
|
||||
mkNameCompItem origName origMod thingType isInfix docs = CI{..}
|
||||
where
|
||||
compKind = occNameToComKind typeText $ occName origName
|
||||
importedFrom = showModName origMod
|
||||
importedFrom = Right $ showModName origMod
|
||||
isTypeCompl = isTcOcc $ occName origName
|
||||
label = T.pack $ showGhc origName
|
||||
insertText = case isInfix of
|
||||
@ -351,15 +355,15 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
|
||||
]
|
||||
|
||||
mkComp n ctyp ty =
|
||||
CI ctyp pn thisModName ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass])
|
||||
CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass])
|
||||
where
|
||||
pn = ppr n
|
||||
doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
|
||||
|
||||
thisModName = ppr hsmodName
|
||||
|
||||
ppr :: Outputable a => a -> T.Text
|
||||
ppr = T.pack . prettyPrint
|
||||
ppr :: Outputable a => a -> T.Text
|
||||
ppr = T.pack . prettyPrint
|
||||
|
||||
newtype WithSnippets = WithSnippets Bool
|
||||
|
||||
@ -375,15 +379,15 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
|
||||
getCompletions
|
||||
:: IdeOptions
|
||||
-> CachedCompletions
|
||||
-> ParsedModule
|
||||
-> PositionMapping -- ^ map current position to position in parsed module
|
||||
-> Maybe (ParsedModule, PositionMapping)
|
||||
-> (Bindings, PositionMapping)
|
||||
-> VFS.PosPrefixInfo
|
||||
-> ClientCapabilities
|
||||
-> WithSnippets
|
||||
-> IO [CompletionItem]
|
||||
getCompletions ideOpts cc pm pmapping prefixInfo caps withSnippets = do
|
||||
let CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules } = cc
|
||||
VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
|
||||
getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules}
|
||||
maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do
|
||||
let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
|
||||
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
|
||||
fullPrefix = enteredQual <> prefixText
|
||||
|
||||
@ -392,19 +396,7 @@ getCompletions ideOpts cc pm pmapping prefixInfo caps withSnippets = do
|
||||
to 'foo :: Int -> String -> '
|
||||
^
|
||||
-}
|
||||
pos =
|
||||
let Position l c = VFS.cursorPos prefixInfo
|
||||
typeStuff = [isSpace, (`elem` (">-." :: String))]
|
||||
stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
|
||||
-- if oldPos points to
|
||||
-- foo -> bar -> baz
|
||||
-- ^
|
||||
-- Then only take the line up to there, discard '-> bar -> baz'
|
||||
partialLine = T.take c fullLine
|
||||
-- drop characters used when writing incomplete type sigs
|
||||
-- like '-> '
|
||||
d = T.length fullLine - T.length (stripTypeStuff partialLine)
|
||||
in Position l (c - d)
|
||||
pos = VFS.cursorPos prefixInfo
|
||||
|
||||
filtModNameCompls =
|
||||
map mkModCompl
|
||||
@ -413,9 +405,15 @@ getCompletions ideOpts cc pm pmapping prefixInfo caps withSnippets = do
|
||||
|
||||
filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
|
||||
where
|
||||
mcc = do
|
||||
position' <- fromCurrentPosition pmapping pos
|
||||
getCContext position' pm
|
||||
|
||||
mcc = case maybe_parsed of
|
||||
Nothing -> Nothing
|
||||
Just (pm, pmapping) ->
|
||||
let PositionMapping pDelta = pmapping
|
||||
position' = fromDelta pDelta pos
|
||||
lpos = lowerRange position'
|
||||
hpos = upperRange position'
|
||||
in getCContext lpos pm <|> getCContext hpos pm
|
||||
|
||||
-- completions specific to the current context
|
||||
ctxCompls' = case mcc of
|
||||
@ -427,10 +425,26 @@ getCompletions ideOpts cc pm pmapping prefixInfo caps withSnippets = do
|
||||
ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
|
||||
|
||||
infixCompls :: Maybe Backtick
|
||||
infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)
|
||||
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
|
||||
|
||||
PositionMapping bDelta = bmapping
|
||||
oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
|
||||
startLoc = lowerRange oldPos
|
||||
endLoc = upperRange oldPos
|
||||
localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
|
||||
localBindsToCompItem :: Name -> Maybe Type -> CompItem
|
||||
localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ)
|
||||
where
|
||||
occ = nameOccName name
|
||||
ctyp = occNameToComKind Nothing occ
|
||||
pn = ppr name
|
||||
ty = ppr <$> typ
|
||||
thisModName = case nameModule_maybe name of
|
||||
Nothing -> Left $ nameSrcSpan name
|
||||
Just m -> Right $ ppr m
|
||||
|
||||
compls = if T.null prefixModule
|
||||
then unqualCompls
|
||||
then localCompls ++ unqualCompls
|
||||
else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
|
||||
|
||||
filtListWith f list =
|
||||
@ -474,6 +488,7 @@ getCompletions ideOpts cc pm pmapping prefixInfo caps withSnippets = do
|
||||
|
||||
return result
|
||||
|
||||
|
||||
-- The supported languages and extensions
|
||||
languagesAndExts :: [T.Text]
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
|
@ -5,6 +5,7 @@ module Development.IDE.Plugin.Completions.Types (
|
||||
import Control.DeepSeq
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import SrcLoc
|
||||
|
||||
import Development.IDE.Spans.Common
|
||||
import Language.Haskell.LSP.Types (CompletionItemKind)
|
||||
@ -17,7 +18,7 @@ data Backtick = Surrounded | LeftSide
|
||||
data CompItem = CI
|
||||
{ compKind :: CompletionItemKind
|
||||
, insertText :: T.Text -- ^ Snippet for the completion
|
||||
, importedFrom :: T.Text -- ^ From where this item is imported from.
|
||||
, importedFrom :: Either SrcSpan T.Text -- ^ From where this item is imported from.
|
||||
, typeText :: Maybe T.Text -- ^ Available type information.
|
||||
, label :: T.Text -- ^ Label to display to the user.
|
||||
, isInfix :: Maybe Backtick -- ^ Did the completion happen
|
||||
|
@ -7,26 +7,31 @@ module Development.IDE.Spans.AtPoint (
|
||||
atPoint
|
||||
, gotoDefinition
|
||||
, gotoTypeDefinition
|
||||
, documentHighlight
|
||||
, pointCommand
|
||||
) where
|
||||
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.GHC.Orphans()
|
||||
import Development.IDE.Types.Location
|
||||
import Language.Haskell.LSP.Types
|
||||
|
||||
-- DAML compiler and infrastructure
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.Types.Options
|
||||
import Development.IDE.Spans.Type as SpanInfo
|
||||
import Development.IDE.Spans.Common (showName, spanDocToMarkdown)
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Core.RuleTypes
|
||||
|
||||
-- GHC API imports
|
||||
import FastString
|
||||
import Name
|
||||
import Outputable hiding ((<>))
|
||||
import SrcLoc
|
||||
import Type
|
||||
import VarSet
|
||||
import TyCoRep
|
||||
import TyCon
|
||||
import qualified Var
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Extra
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Class
|
||||
@ -34,102 +39,91 @@ import Control.Monad.IO.Class
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
import Data.Either
|
||||
import Data.List.Extra (dropEnd1)
|
||||
|
||||
documentHighlight
|
||||
:: Monad m
|
||||
=> HieASTs Type
|
||||
-> RefMap
|
||||
-> Position
|
||||
-> MaybeT m [DocumentHighlight]
|
||||
documentHighlight hf rf pos = MaybeT $ pure (Just highlights)
|
||||
where
|
||||
ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo)
|
||||
highlights = do
|
||||
n <- ns
|
||||
ref <- maybe [] id (M.lookup (Right n) rf)
|
||||
pure $ makeHighlight ref
|
||||
makeHighlight (sp,dets) =
|
||||
DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
|
||||
highlightType s =
|
||||
if any (isJust . getScopeFromContext) s
|
||||
then HkWrite
|
||||
else HkRead
|
||||
|
||||
gotoTypeDefinition
|
||||
:: MonadIO m
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> [SpanInfo]
|
||||
-> HieASTs Type
|
||||
-> Position
|
||||
-> MaybeT m [Location]
|
||||
gotoTypeDefinition getHieFile ideOpts srcSpans pos
|
||||
= typeLocationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
= lift $ typeLocationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
|
||||
-- | Locate the definition of the name at a given position.
|
||||
gotoDefinition
|
||||
:: MonadIO m
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> [SpanInfo]
|
||||
-> M.Map ModuleName NormalizedFilePath
|
||||
-> HieASTs Type
|
||||
-> Position
|
||||
-> MaybeT m Location
|
||||
gotoDefinition getHieFile ideOpts srcSpans pos =
|
||||
MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans
|
||||
gotoDefinition getHieFile ideOpts imports srcSpans pos
|
||||
= MaybeT $ fmap listToMaybe $ locationsAtPoint getHieFile ideOpts imports pos srcSpans
|
||||
|
||||
-- | Synopsis for the name at a given position.
|
||||
atPoint
|
||||
:: IdeOptions
|
||||
-> SpansInfo
|
||||
-> HieASTs Type
|
||||
-> DocAndKindMap
|
||||
-> Position
|
||||
-> Maybe (Maybe Range, [T.Text])
|
||||
atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
|
||||
firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
|
||||
let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
|
||||
-- Filter out the empty lines so we don't end up with a bunch of
|
||||
-- horizontal separators with nothing inside of them
|
||||
text = filter (not . T.null) $ hoverInfo firstSpan constraintsAtPoint
|
||||
return (Just (range firstSpan), text)
|
||||
atPoint IdeOptions{} hf (DKMap dm km) pos = listToMaybe $ pointCommand hf pos hoverInfo
|
||||
where
|
||||
-- Hover info for types, classes, type variables
|
||||
hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =
|
||||
(wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
|
||||
where
|
||||
name = [maybe shouldNotHappen showName mbName]
|
||||
location = [maybe shouldNotHappen definedAt mbName]
|
||||
shouldNotHappen = "ghcide: did not expect a type level component without a name"
|
||||
mbName = getNameM spaninfoSource
|
||||
|
||||
-- Hover info for values/data
|
||||
hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =
|
||||
(wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
|
||||
where
|
||||
mbName = getNameM spaninfoSource
|
||||
expr = case spaninfoSource of
|
||||
Named n -> qualifyNameIfPossible n
|
||||
Lit l -> crop $ T.pack l
|
||||
_ -> ""
|
||||
nameOrSource = [expr <> "\n" <> typeAnnotation]
|
||||
qualifyNameIfPossible name' = modulePrefix <> showName name'
|
||||
where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
|
||||
location = [maybe "" definedAt mbName]
|
||||
hoverInfo ast =
|
||||
(Just range, prettyNames ++ pTypes)
|
||||
where
|
||||
pTypes
|
||||
| length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes
|
||||
| otherwise = map wrapHaskell prettyTypes
|
||||
|
||||
thisFVs = tyCoVarsOfType typ
|
||||
constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
|
||||
constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
|
||||
range = realSrcSpanToRange $ nodeSpan ast
|
||||
|
||||
typeAnnotation = case constraintsOverFVs of
|
||||
[] -> colon <> showName typ
|
||||
[_] -> colon <> constraintsT <> "\n=> " <> showName typ
|
||||
_ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
|
||||
wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
|
||||
info = nodeInfo ast
|
||||
names = M.assocs $ nodeIdentifiers info
|
||||
types = nodeType info
|
||||
|
||||
definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
|
||||
|
||||
crop txt
|
||||
| T.length txt > 50 = T.take 46 txt <> " ..."
|
||||
| otherwise = txt
|
||||
|
||||
range SpanInfo{..} = Range
|
||||
(Position spaninfoStartLine spaninfoStartCol)
|
||||
(Position spaninfoEndLine spaninfoEndCol)
|
||||
|
||||
colon = if optNewColonConvention then ": " else ":: "
|
||||
wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
|
||||
|
||||
-- NOTE(RJR): This is a bit hacky.
|
||||
-- We don't want to show the user type signatures generated from Eq and Show
|
||||
-- instances, as they do not appear in the source program.
|
||||
-- However the user could have written an `==` or `show` function directly,
|
||||
-- in which case we still want to show information for that.
|
||||
-- Hence we just move such information later in the list of spans.
|
||||
deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
|
||||
deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
|
||||
isTypeclassDeclSpan :: SpanInfo -> Bool
|
||||
isTypeclassDeclSpan spanInfo =
|
||||
case getNameM (spaninfoSource spanInfo) of
|
||||
Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
|
||||
Nothing -> False
|
||||
prettyNames :: [T.Text]
|
||||
prettyNames = map prettyName names
|
||||
prettyName (Right n, dets) = T.unlines $
|
||||
wrapHaskell (showName n <> maybe "" ((" :: " <>) . prettyType) (identType dets <|> M.lookup n km))
|
||||
: definedAt n
|
||||
: catMaybes [ T.unlines . spanDocToMarkdown <$> M.lookup n dm
|
||||
]
|
||||
prettyName (Left m,_) = showName m
|
||||
|
||||
prettyTypes = map (("_ :: "<>) . prettyType) types
|
||||
prettyType t = showName t
|
||||
|
||||
definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*"
|
||||
|
||||
typeLocationsAtPoint
|
||||
:: forall m
|
||||
@ -137,50 +131,40 @@ typeLocationsAtPoint
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan
|
||||
where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan)
|
||||
getTypeSpan SpanInfo { spaninfoType = Just t } =
|
||||
case splitTyConApp_maybe t of
|
||||
Nothing -> return Nothing
|
||||
Just (getName -> name, _) ->
|
||||
nameToLocation getHieFile name
|
||||
getTypeSpan _ = return Nothing
|
||||
-> HieASTs Type
|
||||
-> m [Location]
|
||||
typeLocationsAtPoint getHieFile _ideOptions pos ast =
|
||||
let ts = concat $ pointCommand ast pos (nodeType . nodeInfo)
|
||||
ns = flip mapMaybe ts $ \case
|
||||
TyConApp tc _ -> Just $ tyConName tc
|
||||
TyVarTy n -> Just $ Var.varName n
|
||||
_ -> Nothing
|
||||
in mapMaybeM (nameToLocation getHieFile) ns
|
||||
|
||||
locationsAtPoint
|
||||
:: forall m
|
||||
. MonadIO m
|
||||
=> (Module -> MaybeT m (HieFile, FilePath))
|
||||
-> IdeOptions
|
||||
-> M.Map ModuleName NormalizedFilePath
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource)
|
||||
where getSpan :: SpanSource -> m (Maybe SrcSpan)
|
||||
getSpan NoSource = pure Nothing
|
||||
getSpan (SpanS sp) = pure $ Just sp
|
||||
getSpan (Lit _) = pure Nothing
|
||||
getSpan (Named name) = nameToLocation getHieFile name
|
||||
|
||||
querySpanInfoAt :: forall m
|
||||
. MonadIO m
|
||||
=> (SpanInfo -> m (Maybe SrcSpan))
|
||||
-> IdeOptions
|
||||
-> Position
|
||||
-> [SpanInfo]
|
||||
-> MaybeT m [Location]
|
||||
querySpanInfoAt getSpan _ideOptions pos =
|
||||
lift . fmap (mapMaybe srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos
|
||||
-> HieASTs Type
|
||||
-> m [Location]
|
||||
locationsAtPoint getHieFile _ideOptions imports pos ast =
|
||||
let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo)
|
||||
zeroPos = Position 0 0
|
||||
zeroRange = Range zeroPos zeroPos
|
||||
modToLocation m = fmap (\fs -> Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports
|
||||
in mapMaybeM (either (pure . modToLocation) $ nameToLocation getHieFile) ns
|
||||
|
||||
-- | Given a 'Name' attempt to find the location where it is defined.
|
||||
nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan)
|
||||
nameToLocation getHieFile name =
|
||||
nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe Location)
|
||||
nameToLocation getHieFile name = fmap (srcSpanToLocation =<<) $
|
||||
case nameSrcSpan name of
|
||||
sp@(RealSrcSpan _) -> pure $ Just sp
|
||||
sp@(UnhelpfulSpan _) -> runMaybeT $ do
|
||||
guard (sp /= wiredInSrcSpan)
|
||||
-- This case usually arises when the definition is in an external package (DAML only).
|
||||
-- This case usually arises when the definition is in an external package.
|
||||
-- In this case the interface files contain garbage source spans
|
||||
-- so we instead read the .hie files to get useful source spans.
|
||||
mod <- MaybeT $ return $ nameModule_maybe name
|
||||
@ -198,24 +182,16 @@ nameToLocation getHieFile name =
|
||||
setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
|
||||
setFileName _ span@(UnhelpfulSpan _) = span
|
||||
|
||||
-- | Filter out spans which do not enclose a given point
|
||||
spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
|
||||
spansAtPoint pos = filter atp where
|
||||
line = _line pos
|
||||
cha = _character pos
|
||||
atp SpanInfo{..} =
|
||||
startsBeforePosition && endsAfterPosition
|
||||
where
|
||||
startLineCmp = compare spaninfoStartLine line
|
||||
endLineCmp = compare spaninfoEndLine line
|
||||
|
||||
startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)
|
||||
-- The end col points to the column after the
|
||||
-- last character so we use > instead of >=
|
||||
endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
|
||||
pointCommand :: HieASTs Type -> Position -> (HieAST Type -> a) -> [a]
|
||||
pointCommand hf pos k =
|
||||
catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
|
||||
case selectSmallestContaining (sp fs) ast of
|
||||
Nothing -> Nothing
|
||||
Just ast' -> Just $ k ast'
|
||||
where
|
||||
sloc fs = mkRealSrcLoc fs (line+1) (cha+1)
|
||||
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
|
||||
line = _line pos
|
||||
cha = _character pos
|
||||
|
||||
|
||||
getModuleNameAsText :: Name -> Maybe T.Text
|
||||
getModuleNameAsText n = do
|
||||
m <- nameModule_maybe n
|
||||
return . T.pack . moduleNameString $ moduleName m
|
||||
|
@ -1,268 +0,0 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
#include "ghc-api-version.h"
|
||||
|
||||
-- | Get information on modules, identifiers, etc.
|
||||
|
||||
module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
|
||||
|
||||
import ConLike
|
||||
import Control.Monad
|
||||
import qualified CoreUtils
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import DataCon
|
||||
import Desugar
|
||||
import GhcMonad
|
||||
import HscTypes
|
||||
import FastString (mkFastString)
|
||||
import OccName
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Spans.Type
|
||||
import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
|
||||
import Prelude hiding (mod)
|
||||
import TcHsSyn
|
||||
import Var
|
||||
import Development.IDE.Core.Compile
|
||||
import qualified Development.IDE.GHC.Compat as Compat
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Spans.Documentation
|
||||
import Data.List.Extra (nubOrd)
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
|
||||
-- this U ignores that arg in 8.6, but is hidden in 8.4
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
#define U _
|
||||
#else
|
||||
#define U
|
||||
#endif
|
||||
|
||||
-- | Get source span info, used for e.g. AtPoint and Goto Definition.
|
||||
getSrcSpanInfos
|
||||
:: HscEnv
|
||||
-> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
|
||||
-> TcModuleResult
|
||||
-> [ParsedModule] -- ^ Dependencies parsed, optional if the 'HscEnv' already contains docs
|
||||
-> IO SpansInfo
|
||||
getSrcSpanInfos env imports tc parsedDeps =
|
||||
evalGhcEnv env $
|
||||
getSpanInfo imports tc parsedDeps
|
||||
|
||||
-- | Get ALL source spans in the module.
|
||||
getSpanInfo :: GhcMonad m
|
||||
=> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
|
||||
-> TcModuleResult
|
||||
-> [ParsedModule]
|
||||
-> m SpansInfo
|
||||
getSpanInfo mods TcModuleResult{tmrModInfo, tmrModule = tcm@TypecheckedModule{..}} parsedDeps =
|
||||
do let tcs = tm_typechecked_source
|
||||
bs = listifyAllSpans tcs :: [LHsBind GhcTc]
|
||||
es = listifyAllSpans tcs :: [LHsExpr GhcTc]
|
||||
ps = listifyAllSpans' tcs :: [Pat GhcTc]
|
||||
ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
|
||||
allModules = tm_parsed_module : parsedDeps
|
||||
funBinds = funBindMap tm_parsed_module
|
||||
thisMod = ms_mod $ pm_mod_summary tm_parsed_module
|
||||
modIface = hm_iface tmrModInfo
|
||||
|
||||
-- Load this module in HPT to make its interface documentation available
|
||||
modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
|
||||
|
||||
bts <- mapM (getTypeLHsBind funBinds) bs -- binds
|
||||
ets <- mapM getTypeLHsExpr es -- expressions
|
||||
pts <- mapM getTypeLPat ps -- patterns
|
||||
tts <- concat <$> mapM getLHsType ts -- types
|
||||
|
||||
-- Batch extraction of kinds
|
||||
let typeNames = nubOrd [ n | (Named n, _) <- tts]
|
||||
kinds <- Map.fromList . zip typeNames <$> mapM (lookupKind thisMod) typeNames
|
||||
let withKind (Named n, x) =
|
||||
(Named n, x, join $ Map.lookup n kinds)
|
||||
withKind (other, x) =
|
||||
(other, x, Nothing)
|
||||
tts <- pure $ map withKind tts
|
||||
|
||||
let imports = importInfo mods
|
||||
let exports = getExports tcm
|
||||
let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ tts ++ catMaybes (ets ++ pts)
|
||||
let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
|
||||
sortedExprs = sortBy cmp exprs
|
||||
sortedConstraints = sortBy cmp constraints
|
||||
|
||||
-- Batch extraction of Haddocks
|
||||
let names = nubOrd [ s | (Named s,_,_) <- sortedExprs ++ sortedConstraints]
|
||||
docs <- Map.fromList . zip names <$> getDocumentationsTryGhc thisMod allModules names
|
||||
let withDocs (Named n, x, y) = (Named n, x, y, Map.findWithDefault emptySpanDoc n docs)
|
||||
withDocs (other, x, y) = (other, x, y, emptySpanDoc)
|
||||
|
||||
return $ SpansInfo (mapMaybe (toSpanInfo . withDocs) sortedExprs)
|
||||
(mapMaybe (toSpanInfo . withDocs) sortedConstraints)
|
||||
where cmp (_,a,_) (_,b,_)
|
||||
| a `isSubspanOf` b = LT
|
||||
| b `isSubspanOf` a = GT
|
||||
| otherwise = compare (srcSpanStart a) (srcSpanStart b)
|
||||
|
||||
addEmptyInfo = map (\(a,b) -> (a,b,Nothing))
|
||||
constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty)
|
||||
|
||||
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
|
||||
lookupKind mod =
|
||||
fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
|
||||
-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
|
||||
-- points to the first match) whereas the parsed module has the correct locations.
|
||||
-- Therefore we build up a map from OccName to the corresponding definition in the parsed module
|
||||
-- to lookup precise locations for things like multi-clause function definitions.
|
||||
--
|
||||
-- For now this only contains FunBinds.
|
||||
funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
|
||||
funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
|
||||
|
||||
getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]
|
||||
getExports m
|
||||
| Just (_, _, Just exports, _) <- renamedSource m =
|
||||
[ (Named $ unLoc n, getLoc n)
|
||||
| (e, _) <- exports
|
||||
, n <- ieLNames $ unLoc e
|
||||
]
|
||||
getExports _ = []
|
||||
|
||||
-- | Variant of GHC's ieNames that produces LIdP instead of IdP
|
||||
ieLNames :: IE pass -> [Located (IdP pass)]
|
||||
ieLNames (IEVar U n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingAbs U n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingAll n ) = [ieLWrappedName n]
|
||||
ieLNames (IEThingWith n _ ns _) = ieLWrappedName n : map ieLWrappedName ns
|
||||
ieLNames _ = []
|
||||
|
||||
-- | Get the name and type of a binding.
|
||||
getTypeLHsBind :: (Monad m)
|
||||
=> OccEnv (HsBind GhcPs)
|
||||
-> LHsBind GhcTc
|
||||
-> m [(SpanSource, SrcSpan, Maybe Type)]
|
||||
getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})
|
||||
| Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
|
||||
let name = getName (unLoc pid)
|
||||
return [(Named name, getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
|
||||
-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
|
||||
getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
|
||||
let name = getName (unLoc pid)
|
||||
return [(Named name, getLoc pid, Just (varType (unLoc pid)))]
|
||||
getTypeLHsBind _ _ = return []
|
||||
|
||||
-- | Get information about constraints
|
||||
getConstraintsLHsBind :: LHsBind GhcTc
|
||||
-> [(SrcSpan, Type)]
|
||||
getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
|
||||
= map (\v -> (spn, varType v)) vars
|
||||
getConstraintsLHsBind _ = []
|
||||
|
||||
-- | Get the name and type of an expression.
|
||||
getTypeLHsExpr :: (GhcMonad m)
|
||||
=> LHsExpr GhcTc
|
||||
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
|
||||
getTypeLHsExpr e = do
|
||||
hs_env <- getSession
|
||||
(_, mbe) <- liftIO (deSugarExpr hs_env e)
|
||||
case mbe of
|
||||
Just expr -> do
|
||||
let ss = getSpanSource (unLoc e)
|
||||
return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr))
|
||||
Nothing -> return Nothing
|
||||
where
|
||||
getSpanSource :: HsExpr GhcTc -> SpanSource
|
||||
getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
|
||||
getSpanSource (HsVar U (L _ i)) = Named (getName i)
|
||||
getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
|
||||
getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
|
||||
getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
|
||||
getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
|
||||
getSpanSource _ = NoSource
|
||||
|
||||
isLit :: HsExpr GhcTc -> Bool
|
||||
isLit (HsLit U _) = True
|
||||
isLit (HsOverLit U _) = True
|
||||
isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr)
|
||||
isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
|
||||
#else
|
||||
isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr)
|
||||
isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
|
||||
#endif
|
||||
isLit _ = False
|
||||
|
||||
isTupLit (Present U xpr) = isLitChild (unLoc xpr)
|
||||
isTupLit _ = False
|
||||
|
||||
-- We need special treatment for children so things like [(1)] are still treated
|
||||
-- as a list literal while not treating (1) as a literal.
|
||||
isLitChild (HsWrap U _ xpr) = isLitChild xpr
|
||||
isLitChild (HsPar U xpr) = isLitChild (unLoc xpr)
|
||||
#if MIN_GHC_API_VERSION(8,8,0)
|
||||
isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
|
||||
#elif MIN_GHC_API_VERSION(8,6,0)
|
||||
isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
|
||||
#else
|
||||
isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
|
||||
isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
|
||||
#endif
|
||||
isLitChild e = isLit e
|
||||
|
||||
-- | Get the name and type of a pattern.
|
||||
getTypeLPat :: (Monad m)
|
||||
=> Pat GhcTc
|
||||
-> m (Maybe (SpanSource, SrcSpan, Maybe Type))
|
||||
getTypeLPat pat = do
|
||||
let (src, spn) = getSpanSource pat
|
||||
return $ Just (src, spn, Just (hsPatType pat))
|
||||
where
|
||||
getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
|
||||
getSpanSource (VarPat (L spn vid)) = (Named (getName vid), spn)
|
||||
getSpanSource (ConPatOut (L spn (RealDataCon dc)) _ _ _ _ _ _) =
|
||||
(Named (dataConName dc), spn)
|
||||
getSpanSource _ = (NoSource, noSrcSpan)
|
||||
|
||||
getLHsType
|
||||
:: Monad m
|
||||
=> LHsType GhcRn
|
||||
-> m [(SpanSource, SrcSpan)]
|
||||
getLHsType (L spn (HsTyVar U _ v)) = do
|
||||
let n = unLoc v
|
||||
pure [(Named n, spn)]
|
||||
getLHsType _ = pure []
|
||||
|
||||
importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
|
||||
-> [(SpanSource, SrcSpan)]
|
||||
importInfo = mapMaybe (uncurry wrk) where
|
||||
wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
|
||||
wrk modName = \case
|
||||
Nothing -> Nothing
|
||||
Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
|
||||
|
||||
-- TODO make this point to the module name
|
||||
fpToSpanSource :: FilePath -> SpanSource
|
||||
fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
|
||||
|
||||
-- | Pretty print the types into a 'SpanInfo'.
|
||||
toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
|
||||
toSpanInfo (name,mspan,typ,docs) =
|
||||
case mspan of
|
||||
RealSrcSpan spn ->
|
||||
-- GHC’s line and column numbers are 1-based while LSP’s line and column
|
||||
-- numbers are 0-based.
|
||||
Just (SpanInfo (srcSpanStartLine spn - 1)
|
||||
(srcSpanStartCol spn - 1)
|
||||
(srcSpanEndLine spn - 1)
|
||||
(srcSpanEndCol spn - 1)
|
||||
typ
|
||||
name
|
||||
docs)
|
||||
_ -> Nothing
|
@ -1,11 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
#include "ghc-api-version.h"
|
||||
|
||||
module Development.IDE.Spans.Common (
|
||||
showGhc
|
||||
, showName
|
||||
, listifyAllSpans
|
||||
, listifyAllSpans'
|
||||
, safeTyThingId
|
||||
, safeTyThingType
|
||||
, SpanDoc(..)
|
||||
@ -13,13 +13,16 @@ module Development.IDE.Spans.Common (
|
||||
, emptySpanDoc
|
||||
, spanDocToMarkdown
|
||||
, spanDocToMarkdownForTest
|
||||
, DocMap
|
||||
, KindMap
|
||||
) where
|
||||
|
||||
import Data.Data
|
||||
import qualified Data.Generics
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.List.Extra
|
||||
import Data.Map (Map)
|
||||
import Control.DeepSeq
|
||||
import GHC.Generics
|
||||
|
||||
import GHC
|
||||
import Outputable hiding ((<>))
|
||||
@ -30,6 +33,10 @@ import Var
|
||||
|
||||
import qualified Documentation.Haddock.Parser as H
|
||||
import qualified Documentation.Haddock.Types as H
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
|
||||
type DocMap = Map Name SpanDoc
|
||||
type KindMap = Map Name Type
|
||||
|
||||
showGhc :: Outputable a => a -> String
|
||||
showGhc = showPpr unsafeGlobalDynFlags
|
||||
@ -40,18 +47,6 @@ showName = T.pack . prettyprint
|
||||
prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
|
||||
style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
|
||||
|
||||
-- | Get ALL source spans in the source.
|
||||
listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
|
||||
listifyAllSpans tcs =
|
||||
Data.Generics.listify p tcs
|
||||
where p (L spn _) = isGoodSrcSpan spn
|
||||
-- This is a version of `listifyAllSpans` specialized on picking out
|
||||
-- patterns. It comes about since GHC now defines `type LPat p = Pat
|
||||
-- p` (no top-level locations).
|
||||
listifyAllSpans' :: Typeable a
|
||||
=> TypecheckedSource -> [Pat a]
|
||||
listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
|
||||
|
||||
-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
|
||||
safeTyThingType :: TyThing -> Maybe Type
|
||||
safeTyThingType thing
|
||||
@ -68,13 +63,15 @@ safeTyThingId _ = Nothing
|
||||
data SpanDoc
|
||||
= SpanDocString HsDocString SpanDocUris
|
||||
| SpanDocText [T.Text] SpanDocUris
|
||||
deriving (Eq, Show)
|
||||
deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass NFData
|
||||
|
||||
data SpanDocUris =
|
||||
SpanDocUris
|
||||
{ spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page
|
||||
, spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page
|
||||
} deriving (Eq, Show)
|
||||
} deriving stock (Eq, Show, Generic)
|
||||
deriving anyclass NFData
|
||||
|
||||
emptySpanDoc :: SpanDoc
|
||||
emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
|
||||
|
@ -9,6 +9,8 @@ module Development.IDE.Spans.Documentation (
|
||||
getDocumentation
|
||||
, getDocumentationTryGhc
|
||||
, getDocumentationsTryGhc
|
||||
, DocMap
|
||||
, mkDocMap
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
@ -16,6 +18,7 @@ import Control.Monad.Extra (findM)
|
||||
import Data.Foldable
|
||||
import Data.List.Extra
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
@ -24,6 +27,7 @@ import Development.IDE.Core.Compile
|
||||
import Development.IDE.GHC.Compat
|
||||
import Development.IDE.GHC.Error
|
||||
import Development.IDE.Spans.Common
|
||||
import Development.IDE.Core.RuleTypes
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
@ -33,12 +37,42 @@ import GhcMonad
|
||||
import Packages
|
||||
import Name
|
||||
import Language.Haskell.LSP.Types (getUri, filePathToUri)
|
||||
import Data.Either
|
||||
|
||||
mkDocMap
|
||||
:: GhcMonad m
|
||||
=> [ParsedModule]
|
||||
-> RefMap
|
||||
-> ModIface
|
||||
-> [ModIface]
|
||||
-> m DocAndKindMap
|
||||
mkDocMap sources rm hmi deps =
|
||||
do mapM_ (`loadDepModule` Nothing) (reverse deps)
|
||||
loadDepModule hmi Nothing
|
||||
d <- foldrM getDocs M.empty names
|
||||
k <- foldrM getType M.empty names
|
||||
pure $ DKMap d k
|
||||
where
|
||||
getDocs n map = do
|
||||
doc <- getDocumentationTryGhc mod sources n
|
||||
pure $ M.insert n doc map
|
||||
getType n map
|
||||
| isTcOcc $ occName n = do
|
||||
kind <- lookupKind mod n
|
||||
pure $ maybe id (M.insert n) kind map
|
||||
| otherwise = pure map
|
||||
names = rights $ S.toList idents
|
||||
idents = M.keysSet rm
|
||||
mod = mi_module hmi
|
||||
|
||||
lookupKind :: GhcMonad m => Module -> Name -> m (Maybe Type)
|
||||
lookupKind mod =
|
||||
fmap (either (const Nothing) (safeTyThingType =<<)) . catchSrcErrors "span" . lookupName mod
|
||||
|
||||
getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
|
||||
getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]
|
||||
|
||||
getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m [SpanDoc]
|
||||
|
||||
-- Interfaces are only generated for GHC >= 8.6.
|
||||
-- In older versions, interface files do not embed Haddocks anyway
|
||||
#if MIN_GHC_API_VERSION(8,6,0)
|
||||
|
77
src/Development/IDE/Spans/LocalBindings.hs
Normal file
77
src/Development/IDE/Spans/LocalBindings.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
module Development.IDE.Spans.LocalBindings
|
||||
( Bindings
|
||||
, getLocalScope
|
||||
, getFuzzyScope
|
||||
, bindings
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.IntervalMap.FingerTree (IntervalMap, Interval (..))
|
||||
import qualified Data.IntervalMap.FingerTree as IM
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.List as L
|
||||
import Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, Scope(..), Name, Type)
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.GHC.Error
|
||||
import SrcLoc
|
||||
import NameEnv
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Turn a 'RealSrcSpan' into an 'Interval'.
|
||||
realSrcSpanToInterval :: RealSrcSpan -> Interval Position
|
||||
realSrcSpanToInterval rss =
|
||||
Interval
|
||||
(realSrcLocToPosition $ realSrcSpanStart rss)
|
||||
(realSrcLocToPosition $ realSrcSpanEnd rss)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Compute which identifiers are in scope at every point in the AST. Use
|
||||
-- 'getLocalScope' to find the results.
|
||||
bindings :: RefMap -> Bindings
|
||||
bindings refmap = Bindings $ L.foldl' (flip (uncurry IM.insert)) mempty $ do
|
||||
(ident, refs) <- M.toList refmap
|
||||
Right name <- pure ident
|
||||
(_, ident_details) <- refs
|
||||
let ty = identType ident_details
|
||||
info <- S.toList $ identInfo ident_details
|
||||
Just scopes <- pure $ getScopeFromContext info
|
||||
scope <- scopes >>= \case
|
||||
LocalScope scope -> pure $ realSrcSpanToInterval scope
|
||||
_ -> []
|
||||
pure ( scope
|
||||
, unitNameEnv name (name,ty)
|
||||
)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The available bindings at every point in a Haskell tree.
|
||||
newtype Bindings = Bindings
|
||||
{ getBindings :: IntervalMap Position (NameEnv (Name, Maybe Type))
|
||||
} deriving newtype (Semigroup, Monoid)
|
||||
instance NFData Bindings where
|
||||
rnf = rwhnf
|
||||
instance Show Bindings where
|
||||
show _ = "<bindings>"
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a 'Bindings' get every identifier in scope at the given
|
||||
-- 'RealSrcSpan',
|
||||
getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)]
|
||||
getLocalScope bs rss
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.dominators (realSrcSpanToInterval rss)
|
||||
$ getBindings bs
|
||||
|
||||
-- | Lookup all names in scope in any span that intersects the interval
|
||||
-- defined by the two positions.
|
||||
-- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping`
|
||||
getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)]
|
||||
getFuzzyScope bs a b
|
||||
= nameEnvElts
|
||||
$ foldMap snd
|
||||
$ IM.intersections (Interval a b)
|
||||
$ getBindings bs
|
@ -1,77 +0,0 @@
|
||||
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
-- ORIGINALLY COPIED FROM https://github.com/commercialhaskell/intero
|
||||
|
||||
-- | Types used separate to GHCi vanilla.
|
||||
|
||||
module Development.IDE.Spans.Type(
|
||||
SpansInfo(..)
|
||||
, SpanInfo(..)
|
||||
, SpanSource(..)
|
||||
, getNameM
|
||||
) where
|
||||
|
||||
import GHC
|
||||
import Control.DeepSeq
|
||||
import OccName
|
||||
import Development.IDE.GHC.Util
|
||||
import Development.IDE.Spans.Common
|
||||
|
||||
data SpansInfo =
|
||||
SpansInfo { spansExprs :: [SpanInfo]
|
||||
, spansConstraints :: [SpanInfo] }
|
||||
deriving Show
|
||||
|
||||
instance NFData SpansInfo where
|
||||
rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c
|
||||
|
||||
-- | Type of some span of source code. Most of these fields are
|
||||
-- unboxed but Haddock doesn't show that.
|
||||
data SpanInfo =
|
||||
SpanInfo {spaninfoStartLine :: {-# UNPACK #-} !Int
|
||||
-- ^ Start line of the span, zero-based.
|
||||
,spaninfoStartCol :: {-# UNPACK #-} !Int
|
||||
-- ^ Start column of the span, zero-based.
|
||||
,spaninfoEndLine :: {-# UNPACK #-} !Int
|
||||
-- ^ End line of the span (absolute), zero-based.
|
||||
,spaninfoEndCol :: {-# UNPACK #-} !Int
|
||||
-- ^ End column of the span (absolute), zero-based.
|
||||
,spaninfoType :: !(Maybe Type)
|
||||
-- ^ A pretty-printed representation for the type.
|
||||
,spaninfoSource :: !SpanSource
|
||||
-- ^ The actutal 'Name' associated with the span, if
|
||||
-- any. This can be useful for accessing a variety of
|
||||
-- information about the identifier such as module,
|
||||
-- locality, definition location, etc.
|
||||
,spaninfoDocs :: !SpanDoc
|
||||
-- ^ Documentation for the element
|
||||
}
|
||||
instance Show SpanInfo where
|
||||
show (SpanInfo sl sc el ec t n docs) =
|
||||
unwords ["(SpanInfo", show sl, show sc, show el, show ec
|
||||
, show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"
|
||||
, "docs(" <> show docs <> ")"]
|
||||
|
||||
instance NFData SpanInfo where
|
||||
rnf = rwhnf
|
||||
|
||||
|
||||
-- we don't always get a name out so sometimes manually annotating source is more appropriate
|
||||
data SpanSource = Named Name
|
||||
| SpanS SrcSpan
|
||||
| Lit String
|
||||
| NoSource
|
||||
deriving (Eq)
|
||||
|
||||
instance Show SpanSource where
|
||||
show = \case
|
||||
Named n -> "Named " ++ occNameString (occName n)
|
||||
SpanS sp -> "Span " ++ show sp
|
||||
Lit lit -> "Lit " ++ lit
|
||||
NoSource -> "NoSource"
|
||||
|
||||
getNameM :: SpanSource -> Maybe Name
|
||||
getNameM = \case
|
||||
Named name -> Just name
|
||||
_ -> Nothing
|
159
test/exe/Main.hs
159
test/exe/Main.hs
@ -75,6 +75,7 @@ main = do
|
||||
, codeActionTests
|
||||
, codeLensesTests
|
||||
, outlineTests
|
||||
, highlightTests
|
||||
, findDefinitionAndHoverTests
|
||||
, pluginSimpleTests
|
||||
, pluginParsedResultTests
|
||||
@ -117,7 +118,7 @@ initializeResponseTests = withResource acquire release tests where
|
||||
-- for now
|
||||
, chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic True)
|
||||
, chk "NO find references" _referencesProvider Nothing
|
||||
, chk "NO doc highlight" _documentHighlightProvider Nothing
|
||||
, chk " doc highlight" _documentHighlightProvider (Just True)
|
||||
, chk " doc symbol" _documentSymbolProvider (Just True)
|
||||
, chk "NO workspace symbol" _workspaceSymbolProvider Nothing
|
||||
, chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
|
||||
@ -2193,7 +2194,7 @@ findDefinitionAndHoverTests = let
|
||||
opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
|
||||
aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
|
||||
b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
|
||||
xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
|
||||
xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text"]]
|
||||
clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
|
||||
clL25 = Position 29 9
|
||||
eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in 'GHC.Num'"]]
|
||||
@ -2227,7 +2228,7 @@ findDefinitionAndHoverTests = let
|
||||
mkFindTests
|
||||
-- def hover look expect
|
||||
[ test yes yes fffL4 fff "field in record definition"
|
||||
, test broken broken fffL8 fff "field in record construction #71"
|
||||
, test yes yes fffL8 fff "field in record construction #71"
|
||||
, test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
|
||||
, test yes yes aaaL14 aaa "top-level name" -- 120
|
||||
, test yes yes dcL7 tcDC "data constructor record #247"
|
||||
@ -2249,16 +2250,20 @@ findDefinitionAndHoverTests = let
|
||||
, test yes yes lclL33 lcb "listcomp lookup"
|
||||
, test yes yes mclL36 mcl "top-level fn 1st clause"
|
||||
, test yes yes mclL37 mcl "top-level fn 2nd clause #246"
|
||||
, test yes yes spaceL37 space "top-level fn on space #315"
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
, test yes yes spaceL37 space "top-level fn on space #315"
|
||||
#else
|
||||
, test yes broken spaceL37 space "top-level fn on space #315"
|
||||
#endif
|
||||
, test no yes docL41 doc "documentation #7"
|
||||
, test no yes eitL40 kindE "kind of Either #273"
|
||||
, test no yes intL40 kindI "kind of Int #273"
|
||||
, test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
|
||||
, test no yes intL41 litI "literal Int in hover info #274"
|
||||
, test no yes chrL36 litC "literal Char in hover info #274"
|
||||
, test no yes txtL8 litT "literal Text in hover info #274"
|
||||
, test no yes lstL43 litL "literal List in hover info #274"
|
||||
, test no yes docL41 constr "type constraint in hover info #283"
|
||||
, test no broken intL41 litI "literal Int in hover info #274"
|
||||
, test no broken chrL36 litC "literal Char in hover info #274"
|
||||
, test no broken txtL8 litT "literal Text in hover info #274"
|
||||
, test no broken lstL43 litL "literal List in hover info #274"
|
||||
, test no broken docL41 constr "type constraint in hover info #283"
|
||||
, test broken broken outL45 outSig "top-level signature #310"
|
||||
, test broken broken innL48 innSig "inner signature #310"
|
||||
, test no yes cccL17 docLink "Haddock html links"
|
||||
@ -2524,6 +2529,7 @@ completionTests :: TestTree
|
||||
completionTests
|
||||
= testGroup "completion"
|
||||
[ testGroup "non local" nonLocalCompletionTests
|
||||
, testGroup "topLevel" topLevelCompletionTests
|
||||
, testGroup "local" localCompletionTests
|
||||
, testGroup "other" otherCompletionTests
|
||||
]
|
||||
@ -2542,8 +2548,8 @@ completionTest name src pos expected = testSessionWait name $ do
|
||||
when expectedDocs $
|
||||
assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation)
|
||||
|
||||
localCompletionTests :: [TestTree]
|
||||
localCompletionTests = [
|
||||
topLevelCompletionTests :: [TestTree]
|
||||
topLevelCompletionTests = [
|
||||
completionTest
|
||||
"variable"
|
||||
["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
|
||||
@ -2586,6 +2592,67 @@ localCompletionTests = [
|
||||
[("XyRecord", CiConstructor, False, True)]
|
||||
]
|
||||
|
||||
localCompletionTests :: [TestTree]
|
||||
localCompletionTests = [
|
||||
completionTest
|
||||
"argument"
|
||||
["bar (Just abcdef) abcdefg = abcd"]
|
||||
(Position 0 32)
|
||||
[("abcdef", CiFunction, True, False),
|
||||
("abcdefg", CiFunction , True, False)
|
||||
],
|
||||
completionTest
|
||||
"let"
|
||||
["bar = let (Just abcdef) = undefined"
|
||||
," abcdefg = let abcd = undefined in undefined"
|
||||
," in abcd"
|
||||
]
|
||||
(Position 2 15)
|
||||
[("abcdef", CiFunction, True, False),
|
||||
("abcdefg", CiFunction , True, False)
|
||||
],
|
||||
completionTest
|
||||
"where"
|
||||
["bar = abcd"
|
||||
," where (Just abcdef) = undefined"
|
||||
," abcdefg = let abcd = undefined in undefined"
|
||||
]
|
||||
(Position 0 10)
|
||||
[("abcdef", CiFunction, True, False),
|
||||
("abcdefg", CiFunction , True, False)
|
||||
],
|
||||
completionTest
|
||||
"do/1"
|
||||
["bar = do"
|
||||
," Just abcdef <- undefined"
|
||||
," abcd"
|
||||
," abcdefg <- undefined"
|
||||
," pure ()"
|
||||
]
|
||||
(Position 2 6)
|
||||
[("abcdef", CiFunction, True, False)
|
||||
],
|
||||
completionTest
|
||||
"do/2"
|
||||
["bar abcde = do"
|
||||
," Just [(abcdef,_)] <- undefined"
|
||||
," abcdefg <- undefined"
|
||||
," let abcdefgh = undefined"
|
||||
," (Just [abcdefghi]) = undefined"
|
||||
," abcd"
|
||||
," where"
|
||||
," abcdefghij = undefined"
|
||||
]
|
||||
(Position 5 8)
|
||||
[("abcde", CiFunction, True, False)
|
||||
,("abcdefghij", CiFunction, True, False)
|
||||
,("abcdef", CiFunction, True, False)
|
||||
,("abcdefg", CiFunction, True, False)
|
||||
,("abcdefgh", CiFunction, True, False)
|
||||
,("abcdefghi", CiFunction, True, False)
|
||||
]
|
||||
]
|
||||
|
||||
nonLocalCompletionTests :: [TestTree]
|
||||
nonLocalCompletionTests =
|
||||
[ completionTest
|
||||
@ -2636,6 +2703,76 @@ otherCompletionTests = [
|
||||
[("Integer", CiStruct, True, True)]
|
||||
]
|
||||
|
||||
highlightTests :: TestTree
|
||||
highlightTests = testGroup "highlight"
|
||||
[ testSessionWait "value" $ do
|
||||
doc <- createDoc "A.hs" "haskell" source
|
||||
_ <- waitForDiagnostics
|
||||
highlights <- getHighlights doc (Position 2 2)
|
||||
liftIO $ highlights @?=
|
||||
[ DocumentHighlight (R 1 0 1 3) (Just HkRead)
|
||||
, DocumentHighlight (R 2 0 2 3) (Just HkWrite)
|
||||
, DocumentHighlight (R 3 6 3 9) (Just HkRead)
|
||||
, DocumentHighlight (R 4 22 4 25) (Just HkRead)
|
||||
]
|
||||
, testSessionWait "type" $ do
|
||||
doc <- createDoc "A.hs" "haskell" source
|
||||
_ <- waitForDiagnostics
|
||||
highlights <- getHighlights doc (Position 1 8)
|
||||
liftIO $ highlights @?=
|
||||
[ DocumentHighlight (R 1 7 1 10) (Just HkRead)
|
||||
, DocumentHighlight (R 2 11 2 14) (Just HkRead)
|
||||
]
|
||||
, testSessionWait "local" $ do
|
||||
doc <- createDoc "A.hs" "haskell" source
|
||||
_ <- waitForDiagnostics
|
||||
highlights <- getHighlights doc (Position 5 5)
|
||||
liftIO $ highlights @?=
|
||||
[ DocumentHighlight (R 5 4 5 7) (Just HkWrite)
|
||||
, DocumentHighlight (R 5 10 5 13) (Just HkRead)
|
||||
, DocumentHighlight (R 6 12 6 15) (Just HkRead)
|
||||
]
|
||||
, testSessionWait "record" $ do
|
||||
doc <- createDoc "A.hs" "haskell" recsource
|
||||
_ <- waitForDiagnostics
|
||||
highlights <- getHighlights doc (Position 3 15)
|
||||
liftIO $ highlights @?=
|
||||
-- Span is just the .. on 8.10, but Rec{..} before
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
[ DocumentHighlight (R 3 8 3 10) (Just HkWrite)
|
||||
#else
|
||||
[ DocumentHighlight (R 3 4 3 11) (Just HkWrite)
|
||||
#endif
|
||||
, DocumentHighlight (R 3 14 3 20) (Just HkRead)
|
||||
]
|
||||
highlights <- getHighlights doc (Position 2 17)
|
||||
liftIO $ highlights @?=
|
||||
[ DocumentHighlight (R 2 17 2 23) (Just HkWrite)
|
||||
-- Span is just the .. on 8.10, but Rec{..} before
|
||||
#if MIN_GHC_API_VERSION(8,10,0)
|
||||
, DocumentHighlight (R 3 8 3 10) (Just HkRead)
|
||||
#else
|
||||
, DocumentHighlight (R 3 4 3 11) (Just HkRead)
|
||||
#endif
|
||||
]
|
||||
]
|
||||
where
|
||||
source = T.unlines
|
||||
["module Highlight where"
|
||||
,"foo :: Int"
|
||||
,"foo = 3 :: Int"
|
||||
,"bar = foo"
|
||||
," where baz = let x = foo in x"
|
||||
,"baz arg = arg + x"
|
||||
," where x = arg"
|
||||
]
|
||||
recsource = T.unlines
|
||||
["{-# LANGUAGE RecordWildCards #-}"
|
||||
,"module Highlight where"
|
||||
,"data Rec = Rec { field1 :: Int, field2 :: Char }"
|
||||
,"foo Rec{..} = field2 + field1"
|
||||
]
|
||||
|
||||
outlineTests :: TestTree
|
||||
outlineTests = testGroup
|
||||
"outline"
|
||||
|
Loading…
Reference in New Issue
Block a user