haskell/ghcide
1
1
Fork 0
mirror of https://github.com/haskell/ghcide.git synced 2024-11-26 12:25:25 +03:00
Code Issues Projects Releases Wiki Activity

Add GetHieAsts rule, Replace SpanInfo, add support for DocumentHighlight and scope-aware completions for local variables (#784)

Browse Source 
* 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:
wz1000 2020-09-27 13:37:25 +05:30 committed by GitHub
parent 1cda5edf0d
commit 62f4d0644a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
26 changed files with 722 additions and 639 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.azure/linux-stack.yml
View File

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

2
.azure/windows-stack.yml
View File

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

2
.hlint.yaml
View File

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

6
ghcide.cabal
View File

@ -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
src-ghc810/Development/IDE/GHC/HieAst.hs
View File

@ -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 _ -> []

27
src-ghc86/Development/IDE/GHC/HieAst.hs
View File

@ -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 _ -> []

17
src-ghc88/Development/IDE/GHC/HieAst.hs
View File

@ -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 _ -> []

41
src/Development/IDE/Core/Compile.hs
View File

@ -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 (!)

13
src/Development/IDE/Core/PositionMapping.hs
View File

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

62
src/Development/IDE/Core/RuleTypes.hs
View File

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

96
src/Development/IDE/Core/Rules.hs
View File

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

83
src/Development/IDE/GHC/Compat.hs
View File

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

9
src/Development/IDE/GHC/Error.hs
View File

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

19
src/Development/IDE/GHC/Orphans.hs
View File

@ -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
src/Development/IDE/LSP/HoverDefinition.hs
View File

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

1
src/Development/IDE/LSP/LanguageServer.hs
View File

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

13
src/Development/IDE/Plugin/Completions.hs
View File

@ -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 [])

73
src/Development/IDE/Plugin/Completions/Logic.hs
View File

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

3
src/Development/IDE/Plugin/Completions/Types.hs
View File

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

218
src/Development/IDE/Spans/AtPoint.hs
View File

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

268
src/Development/IDE/Spans/Calculate.hs
View File

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

33
src/Development/IDE/Spans/Common.hs
View File

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

36
src/Development/IDE/Spans/Documentation.hs
View File

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

77
src/Development/IDE/Spans/Type.hs
View File

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

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