haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-08-16 03:50:45 +03:00
Code Issues Projects Releases Wiki Activity

Cleanup GHC macros (because min version is 8.8.4) (#3281)

Browse Source 
* Drop min_version_ghc (8.8.4 is min supported)

* Drop conditional glasgow_haskell cpp

* Inline some imports (review feedback)

* Drop hie-compat 8.6 (review feedback)

* Dropping more ghc 8.6 related code and docs

* Eval: Include tests that were broken for 8.6
This commit is contained in:
Andy 2022-10-12 00:35:18 +02:00 committed by GitHub
parent 9b491f7bbf
commit 86e3fd6c65
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
32 changed files with 40 additions and 3497 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
docs/contributing/contributing.md
View File

@ -64,8 +64,6 @@ To create binaries:
* `nix build .#haskell-language-server-884` - GHC 8.8.4
* `nix build .#haskell-language-server-901` - GHC 9.0.1
GHC 8.6.5 is not supported here because `nixpkgs-unstable` no longer maintains the corresponding packages set.
## Testing
The tests make use of the [Tasty](https://github.com/feuerbach/tasty) test framework.

2
docs/contributing/plugin-tutorial.md
View File

@ -34,7 +34,7 @@ And here is the gist of the algorithm:
## Setup
To get started, let’s fetch the HLS repo and build it. You need at least GHC 8.6 for this:
To get started, let’s fetch the HLS repo and build it. You need at least GHC 8.8 for this:
```
git clone --recursive http://github.com/haskell/haskell-language-server hls

2
docs/installation.md
View File

@ -157,7 +157,7 @@ Homebrew users can install `haskell-language-server` using the following command
brew install haskell-language-server
```
This formula contains HLS binaries compiled with GHC versions available via Homebrew; at the moment those are: 8.6.5, 8.8.4, 8.10.7.
This formula contains HLS binaries compiled with GHC versions available via Homebrew; at the moment those are: 8.8.4, 8.10.7.
You need to provide your own GHC/Cabal/Stack as required by your project, possibly via Homebrew.

2
ghcide-bench/ghcide-bench.cabal
View File

@ -12,7 +12,7 @@ synopsis: An LSP client for running performance experiments on HLS
description: An LSP client for running performance experiments on HLS
homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme
bug-reports: https://github.com/haskell/haskell-language-server/issues
tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4
tested-with: GHC == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4
source-repository head
type: git

2
ghcide/README.md
View File

@ -98,7 +98,7 @@ If you can't get `ghcide` working outside the editor, see [this setup troublesho
### Optimal project setup
`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.8, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
### Using with VS Code

4
ghcide/ghcide.cabal
View File

@ -99,7 +99,7 @@ library
unliftio-core,
ghc-boot-th,
ghc-boot,
ghc >= 8.6,
ghc >= 8.8,
ghc-check >=0.5.0.8,
ghc-paths,
cryptohash-sha1 >=0.11.100 && <0.12,
@ -363,7 +363,7 @@ test-suite ghcide-tests
text,
text-rope,
unordered-containers,
if (impl(ghc >= 8.6) && impl(ghc < 9.2))
if impl(ghc < 9.2)
build-depends:
record-dot-preprocessor,
record-hasfield

2
ghcide/src/Development/IDE/Core/Compile.hs
View File

@ -1181,9 +1181,7 @@ getModSummaryFromImports env fp modTime contents = do
msrModSummary =
ModSummary
{ ms_mod = modl
#if MIN_VERSION_ghc(8,8,0)
, ms_hie_date = Nothing
#endif
#if MIN_VERSION_ghc(9,3,0)
, ms_dyn_obj_date = Nothing
, ms_ghc_prim_import = ghc_prim_import

3
ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -62,9 +62,6 @@ module Development.IDE.Core.Rules(
DisplayTHWarning(..),
) where
#if !MIN_VERSION_ghc(8,8,0)
import Control.Applicative (liftA2)
#endif
import Control.Concurrent.Async (concurrently)
import Control.Concurrent.Strict
import Control.DeepSeq

16
ghcide/src/Development/IDE/Core/Tracing.hs
View File

@ -37,18 +37,8 @@ import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent,
beginSpan, endSpan, setTag,
withSpan)
#if MIN_VERSION_ghc(8,8,0)
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
#else
otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a]
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
#endif
withTrace :: (MonadMask m, MonadIO m) =>
String -> ((String -> String -> m ()) -> m a) -> m a
withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a
withTrace name act
| userTracingEnabled
= withSpan (fromString name) $ \sp -> do
@ -56,6 +46,7 @@ withTrace name act
act setSpan'
| otherwise = act (\_ _ -> pure ())
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace name act
| userTracingEnabled
= withSpan (fromString name) $ \sp -> do
@ -125,6 +116,7 @@ otTracedAction key file mode result act
(\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics ))
| otherwise = act (\_ -> return ())
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]
otTracedGarbageCollection label act
| userTracingEnabled = fst <$>
generalBracket
@ -138,6 +130,7 @@ otTracedGarbageCollection label act
(const act)
| otherwise = act
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
otTracedProvider (PluginId pluginName) provider act
| userTracingEnabled = do
runInIO <- askRunInIO
@ -146,4 +139,3 @@ otTracedProvider (PluginId pluginName) provider act
runInIO act
| otherwise = act

49
ghcide/src/Development/IDE/GHC/Compat.hs
View File

@ -228,18 +228,8 @@ import DynFlags hiding (ExposePackage)
import HscTypes
import MkIface hiding (writeIfaceFile)
#if MIN_VERSION_ghc(8,8,0)
import StringBuffer (hPutStringBuffer)
#endif
import qualified SysTools
#if !MIN_VERSION_ghc(8,8,0)
import qualified EnumSet
import SrcLoc (RealLocated)
import Foreign.ForeignPtr
import System.IO
#endif
#endif
import Compat.HieAst (enrichHie)
@ -385,13 +375,6 @@ corePrepExpr _ = GHC.corePrepExpr
simplifyExpr df _ = GHC.simplifyExpr df
#endif
#if !MIN_VERSION_ghc(8,8,0)
hPutStringBuffer :: Handle -> StringBuffer -> IO ()
hPutStringBuffer hdl (StringBuffer buf len cur)
= withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
hPutBuf hdl ptr len
#endif
#if MIN_VERSION_ghc(9,2,0)
type ErrMsg = MsgEnvelope DecoratedSDoc
#endif
@ -445,12 +428,7 @@ hieExportNames = nameListFromAvails . hie_exports
type NameCacheUpdater = NameCache
#else
upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
#if MIN_VERSION_ghc(8,8,0)
upNameCache = updNameCache
#else
upNameCache ref upd_fn
= atomicModifyIORef' ref upd_fn
#endif
#endif
#if !MIN_VERSION_ghc(9,0,1)
@ -480,27 +458,15 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
where f i = i{includePathsQuote = path : includePathsQuote i}
setHieDir :: FilePath -> DynFlags -> DynFlags
setHieDir _f d =
#if MIN_VERSION_ghc(8,8,0)
d { hieDir = Just _f}
#else
d
#endif
setHieDir _f d = d { hieDir = Just _f}
dontWriteHieFiles :: DynFlags -> DynFlags
dontWriteHieFiles d =
#if MIN_VERSION_ghc(8,8,0)
gopt_unset d Opt_WriteHie
#else
d
#endif
dontWriteHieFiles d = gopt_unset d Opt_WriteHie
setUpTypedHoles ::DynFlags -> DynFlags
setUpTypedHoles df
= flip gopt_unset Opt_AbstractRefHoleFits -- too spammy
#if MIN_VERSION_ghc(8,8,0)
$ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used
#endif
$ flip gopt_unset Opt_ShowMatchesOfHoleFits -- nice but broken (forgets module qualifiers)
$ flip gopt_unset Opt_ShowProvOfHoleFits -- not used
$ flip gopt_unset Opt_ShowTypeAppOfHoleFits -- not used
@ -533,12 +499,6 @@ disableWarningsAsErrors :: DynFlags -> DynFlags
disableWarningsAsErrors df =
flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..]
#if !MIN_VERSION_ghc(8,8,0)
wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags
wopt_unset_fatal dfs f
= dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }
#endif
isQualifiedImport :: ImportDecl a -> Bool
#if MIN_VERSION_ghc(8,10,0)
isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False
@ -606,8 +566,7 @@ generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the s
#endif
data GhcVersion
= GHC86
| GHC88
= GHC88
| GHC810
| GHC90
| GHC92
@ -628,8 +587,6 @@ ghcVersion = GHC90
ghcVersion = GHC810
#elif MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)
ghcVersion = GHC88
#elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
ghcVersion = GHC86
#endif
runUnlit :: Logger -> DynFlags -> [Option] -> IO ()

21
ghcide/src/Development/IDE/GHC/Compat/CPP.hs
View File

@ -16,24 +16,20 @@ module Development.IDE.GHC.Compat.CPP (
doCpp
) where
import FileCleanup
import Packages
import Panic
import SysTools
#if MIN_VERSION_ghc(8,8,2)
import LlvmCodeGen (llvmVersionList)
#elif MIN_VERSION_ghc(8,8,0)
import LlvmCodeGen (LlvmVersion (..))
#endif
import Control.Monad
import Data.List (intercalate)
import Data.Maybe
import Data.Version
import DynFlags
import FileCleanup
import LlvmCodeGen (llvmVersionList)
import Module (rtsUnitId, toInstalledUnitId)
import Packages
import Panic
import System.Directory
import System.FilePath
import System.Info
import SysTools
import Development.IDE.GHC.Compat as Compat
@ -136,16 +132,9 @@ getBackendDefs :: DynFlags -> IO [String]
getBackendDefs dflags | hscTarget dflags == HscLlvm = do
llvmVer <- figureLlvmVersion dflags
return $ case llvmVer of
#if MIN_VERSION_ghc(8,8,2)
Just v
| [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
| m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
#elif MIN_VERSION_ghc(8,8,0)
Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
#else
Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
#endif
_ -> []
where
format (major, minor)

73
ghcide/src/Development/IDE/GHC/Compat/Core.hs
View File

@ -36,11 +36,9 @@ module Development.IDE.GHC.Compat.Core (
maxRefHoleFits,
maxValidHoleFits,
setOutputFile,
#if MIN_VERSION_ghc(8,8,0)
CommandLineOption,
#if !MIN_VERSION_ghc(9,2,0)
staticPlugins,
#endif
#endif
sPgm_F,
settings,
@ -242,7 +240,7 @@ module Development.IDE.GHC.Compat.Core (
SrcLoc.mkGeneralSrcSpan,
SrcLoc.mkRealSrcSpan,
SrcLoc.mkRealSrcLoc,
getRealSrcSpan,
SrcLoc.getRealSrcSpan,
SrcLoc.realSrcLocSpan,
SrcLoc.realSrcSpanStart,
SrcLoc.realSrcSpanEnd,
@ -263,7 +261,7 @@ module Development.IDE.GHC.Compat.Core (
SrcLoc.noSrcSpan,
SrcLoc.noSrcLoc,
SrcLoc.noLoc,
#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0)
#if !MIN_VERSION_ghc(8,10,0)
SrcLoc.dL,
#endif
-- * Finder
@ -311,13 +309,13 @@ module Development.IDE.GHC.Compat.Core (
Module.ml_hs_file,
Module.ml_obj_file,
Module.ml_hi_file,
Development.IDE.GHC.Compat.Core.ml_hie_file,
Module.ml_hie_file,
-- * DataCon
Development.IDE.GHC.Compat.Core.dataConExTyCoVars,
DataCon.dataConExTyCoVars,
-- * Role
Role(..),
-- * Panic
PlainGhcException,
Plain.PlainGhcException,
panic,
panicDoc,
-- * Other
@ -734,19 +732,12 @@ import NameCache
import NameEnv
import NameSet
import Packages
#if MIN_VERSION_ghc(8,8,0)
import Panic hiding (try)
import qualified PlainPanic as Plain
#else
import Panic hiding (GhcException, try)
import qualified Panic as Plain
#endif
import Parser
import PatSyn
import RnFixity
#if MIN_VERSION_ghc(8,8,0)
import Plugins
#endif
import PprTyThing hiding (pprFamInst)
import PrelInfo
import PrelNames hiding (Unique, printName)
@ -791,10 +782,8 @@ import SrcLoc (RealLocated,
#endif
#if !MIN_VERSION_ghc(8,8,0)
import Data.List (isSuffixOf)
import System.FilePath
#endif
#if MIN_VERSION_ghc(9,2,0)
@ -931,49 +920,16 @@ pattern L l a <- GHC.L (getLoc -> l) a
{-# COMPLETE L #-}
#endif
#elif MIN_VERSION_ghc(8,8,0)
#else
type HasSrcSpan = SrcLoc.HasSrcSpan
getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan
getLoc = SrcLoc.getLoc
#else
class HasSrcSpan a where
getLoc :: a -> SrcSpan
instance HasSrcSpan Name where
getLoc = nameSrcSpan
instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where
getLoc = SrcLoc.getLoc
#endif
getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan
#if !MIN_VERSION_ghc(8,8,0)
getRealSrcSpan = SrcLoc.getLoc
#else
getRealSrcSpan = SrcLoc.getRealSrcSpan
#endif
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation
#if !MIN_VERSION_ghc(8,8,0)
addBootSuffixLocnOut locn
= locn { Module.ml_hi_file = Module.addBootSuffix (Module.ml_hi_file locn)
, Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn)
}
#else
addBootSuffixLocnOut = Module.addBootSuffixLocnOut
#endif
dataConExTyCoVars :: DataCon -> [TyCoVar]
#if __GLASGOW_HASKELL__ >= 808
dataConExTyCoVars = DataCon.dataConExTyCoVars
#else
dataConExTyCoVars = DataCon.dataConExTyVars
#endif
#if !MIN_VERSION_ghc(9,0,0)
-- Linear Haskell
@ -987,7 +943,7 @@ unrestricted = id
mkVisFunTys :: [Scaled Type] -> Type -> Type
mkVisFunTys =
#if __GLASGOW_HASKELL__ <= 808
#if __GLASGOW_HASKELL__ == 808
mkFunTys
#else
TcType.mkVisFunTys
@ -1030,27 +986,12 @@ noExtField :: GHC.NoExt
noExtField = GHC.noExt
#endif
ml_hie_file :: GHC.ModLocation -> FilePath
#if !MIN_VERSION_ghc(8,8,0)
ml_hie_file ml
| "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot"
| otherwise = Module.ml_hi_file ml -<.> ".hie"
#else
ml_hie_file = Module.ml_hie_file
#endif
#if !MIN_VERSION_ghc(9,0,0)
pattern NotBoot, IsBoot :: IsBootInterface
pattern NotBoot = False
pattern IsBoot = True
#endif
#if MIN_VERSION_ghc(8,8,0)
type PlainGhcException = Plain.PlainGhcException
#else
type PlainGhcException = Plain.GhcException
#endif
#if MIN_VERSION_ghc(9,0,0)
-- This is from the old api, but it still simplifies
pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs

12
ghcide/src/Development/IDE/GHC/Compat/Plugins.hs
View File

@ -4,17 +4,13 @@
module Development.IDE.GHC.Compat.Plugins (
Plugin(..),
defaultPlugin,
#if __GLASGOW_HASKELL__ >= 808
PluginWithArgs(..),
#endif
applyPluginsParsedResultAction,
initializePlugins,
-- * Static plugins
#if MIN_VERSION_ghc(8,8,0)
StaticPlugin(..),
hsc_static_plugins,
#endif
) where
#if MIN_VERSION_ghc(9,0,0)
@ -31,13 +27,9 @@ import GHC.Driver.Plugins (ParsedResult (..),
staticPlugins)
#endif
import qualified GHC.Runtime.Loader as Loader
#elif MIN_VERSION_ghc(8,8,0)
import qualified DynamicLoading as Loader
import Plugins
#else
import qualified DynamicLoading as Loader
import Plugins (Plugin (..), defaultPlugin,
withPlugins)
import Plugins
#endif
import Development.IDE.GHC.Compat.Core
import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags)
@ -76,7 +68,6 @@ initializePlugins env = do
#endif
#if MIN_VERSION_ghc(8,8,0)
hsc_static_plugins :: HscEnv -> [StaticPlugin]
#if MIN_VERSION_ghc(9,3,0)
hsc_static_plugins = staticPlugins . Env.hsc_plugins
@ -85,4 +76,3 @@ hsc_static_plugins = Env.hsc_static_plugins
#else
hsc_static_plugins = staticPlugins . hsc_dflags
#endif
#endif

2
ghcide/src/Development/IDE/GHC/CoreFile.hs
View File

@ -38,7 +38,7 @@ import GHC.Types.TypeEnv
import GHC.Driver.Types
#endif
#elif MIN_VERSION_ghc(8,6,0)
#else
import Binary
import BinFingerprint (fingerprintBinMem)
import BinIface

4
ghcide/src/Development/IDE/Spans/AtPoint.hs
View File

@ -280,11 +280,7 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi
where ni = nodeInfo' x
getTypes ts = flip concatMap (unfold ts) $ \case
HTyVarTy n -> [n]
#if MIN_VERSION_ghc(8,8,0)
HAppTy a (HieArgs xs) -> getTypes (a : map snd xs)
#else
HAppTy a b -> getTypes [a,b]
#endif
HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs)
HForAllTy _ a -> getTypes [a]
#if MIN_VERSION_ghc(9,0,1)

5
ghcide/src/Development/IDE/Spans/Pragmas.hs
View File

@ -416,10 +416,7 @@ mkLexerPState dynFlags stringBuffer =
startRealSrcLoc = mkRealSrcLoc "asdf" 1 1
updateDynFlags = flip gopt_unset Opt_Haddock . flip gopt_set Opt_KeepRawTokenStream
finalDynFlags = updateDynFlags dynFlags
#if !MIN_VERSION_ghc(8,8,1)
pState = mkPState finalDynFlags stringBuffer startRealSrcLoc
finalPState = pState{ use_pos_prags = False }
#elif !MIN_VERSION_ghc(8,10,1)
#if !MIN_VERSION_ghc(8,10,1)
mkLexerParserFlags =
mkParserFlags'
<$> warningFlags

2
ghcide/test/ghcide-test-utils.cabal
View File

@ -14,7 +14,7 @@ description:
Test utils for ghcide
homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme
bug-reports: https://github.com/haskell/haskell-language-server/issues
tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4
tested-with: GHC == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.3 || == 9.2.4
source-repository head
type: git

2
hie-compat/README.md
View File

@ -1,7 +1,7 @@
# hie-compat
Mainly a backport of [HIE
Files](https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files) for ghc 8.6, along
Files](https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files) for ghc 8.8, along
with a few other backports of fixes useful for `ghcide`
Also includes backport of record-dot-syntax support to 9.2.x

6
hie-compat/hie-compat.cabal
View File

@ -1,10 +1,10 @@
cabal-version: 1.22
name: hie-compat
version: 0.3.0.0
synopsis: HIE files for GHC 8.6 and other HIE file backports
synopsis: HIE files for GHC 8.8 and other HIE file backports
license: Apache-2.0
description:
Backports for HIE files to GHC 8.6, along with a few other backports
Backports for HIE files to GHC 8.8, along with a few other backports
of HIE file related fixes for ghcide.
THIS DOES NOT LET YOU READ HIE FILES WITH MISMATCHED VERSIONS OF GHC
@ -46,8 +46,6 @@ library
Compat.HieDebug
Compat.HieUtils
if (impl(ghc > 8.5) && impl(ghc < 8.7) && !flag(ghc-lib))
hs-source-dirs: src-ghc86
if (impl(ghc > 8.7) && impl(ghc < 8.10))
hs-source-dirs: src-ghc88 src-reexport
if (impl(ghc > 8.9) && impl(ghc < 8.11))

1753
hie-compat/src-ghc86/Compat/HieAst.hs
View File

File diff suppressed because it is too large Load Diff

388
hie-compat/src-ghc86/Compat/HieBin.hs
View File

@ -1,388 +0,0 @@
{-
Binary serialization for .hie files.
-}
{-# LANGUAGE ScopedTypeVariables #-}
module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where
import Config ( cProjectVersion )
import Binary
import BinIface ( getDictFastString )
import FastMutInt
import FastString ( FastString )
import Module ( Module )
import Name
import NameCache
import Outputable
import PrelInfo
import SrcLoc
import UniqSupply ( takeUniqFromSupply )
import Util ( maybeRead )
import Unique
import UniqFM
import IfaceEnv
import qualified Data.Array as A
import Data.IORef
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.List ( mapAccumR )
import Data.Word ( Word8, Word32 )
import Control.Monad ( replicateM, when )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
import Compat.HieTypes
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
-- these two types.
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
| KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-- Not actually non determinstic as it is a KnownKey
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
compare LocalName{} _ = LT
compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
}
data HieDictionary = HieDictionary
{ hie_dict_next :: !FastMutInt -- The next index to use
, hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
}
initBinMemSize :: Int
initBinMemSize = 1024*1024
-- | The header for HIE files - Capital ASCII letters "HIE".
hieMagic :: [Word8]
hieMagic = [72,73,69]
hieMagicLen :: Int
hieMagicLen = length hieMagic
ghcVersion :: ByteString
ghcVersion = BSC.pack cProjectVersion
putBinLine :: BinHandle -> ByteString -> IO ()
putBinLine bh xs = do
mapM_ (putByte bh) $ BS.unpack xs
putByte bh 10 -- newline char
-- | Write a `HieFile` to the given `FilePath`, with a proper header and
-- symbol tables for `Name`s and `FastString`s
writeHieFile :: FilePath -> HieFile -> IO ()
writeHieFile hie_file_path hiefile = do
bh0 <- openBinMem initBinMemSize
-- Write the header: hieHeader followed by the
-- hieVersion and the GHC version used to generate this file
mapM_ (putByte bh0) hieMagic
putBinLine bh0 $ BSC.pack $ show hieVersion
putBinLine bh0 ghcVersion
-- remember where the dictionary pointer will go
dict_p_p <- tellBin bh0
put_ bh0 dict_p_p
-- remember where the symbol table pointer will go
symtab_p_p <- tellBin bh0
put_ bh0 symtab_p_p
-- Make some intial state
symtab_next <- newFastMutInt
writeFastMutInt symtab_next 0
symtab_map <- newIORef emptyUFM
let hie_symtab = HieSymbolTable {
hie_symtab_next = symtab_next,
hie_symtab_map = symtab_map }
dict_next_ref <- newFastMutInt
writeFastMutInt dict_next_ref 0
dict_map_ref <- newIORef emptyUFM
let hie_dict = HieDictionary {
hie_dict_next = dict_next_ref,
hie_dict_map = dict_map_ref }
-- put the main thing
let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
(putName hie_symtab)
(putFastString hie_dict)
put_ bh hiefile
-- write the symtab pointer at the front of the file
symtab_p <- tellBin bh
putAt bh symtab_p_p symtab_p
seekBin bh symtab_p
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the front of the file
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt dict_next_ref
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
-- and send the result to the file
createDirectoryIfMissing True (takeDirectory hie_file_path)
writeBinMem bh hie_file_path
return ()
data HieFileResult
= HieFileResult
{ hie_file_result_version :: Integer
, hie_file_result_ghc_version :: ByteString
, hie_file_result :: HieFile
}
type HieHeader = (Integer, ByteString)
-- | Read a `HieFile` from a `FilePath`. Can use
-- an existing `NameCache`. Allows you to specify
-- which versions of hieFile to attempt to read.
-- `Left` case returns the failing header versions.
readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)
readHieFileWithVersion readVersion ncu file = do
bh0 <- readBinMem file
(hieVersion, ghcVersion) <- readHieFileHeader file bh0
if readVersion (hieVersion, ghcVersion)
then do
hieFile <- readHieFileContents bh0 ncu
return $ Right (HieFileResult hieVersion ghcVersion hieFile)
else return $ Left (hieVersion, ghcVersion)
-- | Read a `HieFile` from a `FilePath`. Can use
-- an existing `NameCache`.
readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult
readHieFile ncu file = do
bh0 <- readBinMem file
(readHieVersion, ghcVersion) <- readHieFileHeader file bh0
-- Check if the versions match
when (readHieVersion /= hieVersion) $
panic $ unwords ["readHieFile: hie file versions don't match for file:"
, file
, "Expected"
, show hieVersion
, "but got", show readHieVersion
]
hieFile <- readHieFileContents bh0 ncu
return $ HieFileResult hieVersion ghcVersion hieFile
readBinLine :: BinHandle -> IO ByteString
readBinLine bh = BS.pack . reverse <$> loop []
where
loop acc = do
char <- get bh :: IO Word8
if char == 10 -- ASCII newline '\n'
then return acc
else loop (char : acc)
readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
readHieFileHeader file bh0 = do
-- Read the header
magic <- replicateM hieMagicLen (get bh0)
version <- BSC.unpack <$> readBinLine bh0
case maybeRead version of
Nothing ->
panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
, show version
]
Just readHieVersion -> do
ghcVersion <- readBinLine bh0
-- Check if the header is valid
when (magic /= hieMagic) $
panic $ unwords ["readHieFileHeader: headers don't match for file:"
, file
, "Expected"
, show hieMagic
, "but got", show magic
]
return (readHieVersion, ghcVersion)
readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile
readHieFileContents bh0 ncu = do
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
bh1 <- do
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
(getDictFastString dict)
symtab <- get_symbol_table bh1
let bh1' = setUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return bh1'
-- load the actual data
hiefile <- get bh1
return hiefile
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
data_p <- tellBin bin_handle
seekBin bin_handle dict_p
dict <- getDictionary bin_handle
seekBin bin_handle data_p
return dict
get_symbol_table bh1 = do
symtab_p <- get bh1
data_p' <- tellBin bh1
seekBin bh1 symtab_p
symtab <- getSymbolTable bh1 ncu
seekBin bh1 data_p'
return symtab
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
out <- readIORef out_r
let unique = getUnique f
case lookupUFM out unique of
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out unique (j, f)
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable bh ncu = do
sz <- get bh
od_names <- replicateM sz (getHieName bh)
updateNameCache ncu $ \nc ->
let arr = A.listArray (0,sz-1) names
(nc', names) = mapAccumR fromHieName nc od_names
in (nc',arr)
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName st bh = do
i :: Word32 <- get bh
return $ st A.! fromIntegral i
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName (HieSymbolTable next ref) bh name = do
symmap <- readIORef ref
case lookupUFM symmap name of
Just (off, ExternalName mod occ (UnhelpfulSpan _))
| isGoodSrcSpan (nameSrcSpan name) -> do
let hieName = ExternalName mod occ (nameSrcSpan name)
writeIORef ref $! addToUFM symmap name (off, hieName)
put_ bh (fromIntegral off :: Word32)
Just (off, LocalName _occ span)
| notLocal (toHieName name) || nameSrcSpan name /= span -> do
writeIORef ref $! addToUFM symmap name (off, toHieName name)
put_ bh (fromIntegral off :: Word32)
Just (off, _) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt next
writeFastMutInt next (off+1)
writeIORef ref $! addToUFM symmap name (off, toHieName name)
put_ bh (fromIntegral off :: Word32)
where
notLocal :: HieName -> Bool
notLocal LocalName{} = False
notLocal _ = True
-- ** Converting to and from `HieName`'s
toHieName :: Name -> HieName
toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
(nameSrcSpan name)
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)
fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName nc (ExternalName mod occ span) =
let cache = nsNames nc
in case lookupOrigNameCache cache mod occ of
Just name
| nameSrcSpan name == span -> (nc, name)
| otherwise ->
let name' = setNameLoc name span
new_cache = extendNameCache cache mod occ name'
in ( nc{ nsNames = new_cache }, name' )
Nothing ->
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
name = mkExternalName uniq mod occ span
new_cache = extendNameCache cache mod occ name
in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
fromHieName nc (LocalName occ span) =
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
name = mkInternalName uniq occ span
in ( nc{ nsUniqs = us }, name )
fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
Nothing -> pprPanic "fromHieName:unknown known-key unique"
(ppr (unpkUnique u))
Just n -> (nc, n)
-- ** Reading and writing `HieName`'s
putHieName :: BinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
put_ bh (mod, occ, span)
putHieName bh (LocalName occName span) = do
putByte bh 1
put_ bh (occName, span)
putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
getHieName :: BinHandle -> IO HieName
getHieName bh = do
t <- getByte bh
case t of
0 -> do
(modu, occ, span) <- get bh
return $ ExternalName modu occ span
1 -> do
(occ, span) <- get bh
return $ LocalName occ span
2 -> do
(c,i) <- get bh
return $ KnownKeyName $ mkUnique c i
_ -> panic "HieBin.getHieName: invalid tag"

145
hie-compat/src-ghc86/Compat/HieDebug.hs
View File

@ -1,145 +0,0 @@
{-
Functions to validate and check .hie file ASTs generated by GHC.
-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Compat.HieDebug where
import Prelude hiding ((<>))
import SrcLoc
import Module
import FastString
import Outputable
import Compat.HieTypes
import Compat.HieBin
import Compat.HieUtils
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
import Data.Foldable ( toList )
ppHies :: Outputable a => HieASTs a -> SDoc
ppHies (HieASTs asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat
[ "File: " <> ppr k
, ppHie a
, rest
]
ppHie :: Outputable a => HieAST a -> SDoc
ppHie = go 0
where
go n (Node inf sp children) = hang header n rest
where
rest = vcat $ map (go (n+2)) children
header = hsep
[ "Node"
, ppr sp
, ppInfo inf
]
ppInfo :: Outputable a => NodeInfo a -> SDoc
ppInfo ni = hsep
[ ppr $ toList $ nodeAnnotations ni
, ppr $ nodeType ni
, ppr $ M.toList $ nodeIdentifiers ni
]
type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
diffAsts f = diffList (diffAst f) `on` M.elems
diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
where
spanDiff
| span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
| otherwise = []
infoDiff
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
++ (diffList diffType `on` nodeType) info1 info2
++ (diffIdents `on` nodeIdentifiers) info1 info2
diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
diffIdent (a,b) (c,d) = diffName a c
++ eqDiff b d
diffName (Right a) (Right b) = case (a,b) of
(ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
(LocalName o _, ExternalName _ o' _) -> eqDiff o o'
_ -> eqDiff a b
diffName a b = eqDiff a b
type DiffIdent = Either ModuleName HieName
normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
normalizeIdents = sortOn fst . map (first toHieName) . M.toList
where
first f (a,b) = (fmap f a, b)
diffList :: Diff a -> Diff [a]
diffList f xs ys
| length xs == length ys = concat $ zipWith f xs ys
| otherwise = ["length of lists doesn't match"]
eqDiff :: (Outputable a, Eq a) => Diff a
eqDiff a b
| a == b = []
| otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
validAst :: HieAST a -> Either SDoc ()
validAst (Node _ span children) = do
checkContainment children
checkSorted children
mapM_ validAst children
where
checkSorted [] = return ()
checkSorted [_] = return ()
checkSorted (x:y:xs)
| nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
| otherwise = Left $ hsep
[ ppr $ nodeSpan x
, "is not to the left of"
, ppr $ nodeSpan y
]
checkContainment [] = return ()
checkContainment (x:xs)
| span `containsSpan` nodeSpan x = checkContainment xs
| otherwise = Left $ hsep
[ ppr span
, "does not contain"
, ppr $ nodeSpan x
]
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: M.Map FastString (HieAST a) -> [SDoc]
validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
where
refMap = generateReferencesMap asts
valid (Left _) _ = []
valid (Right n) refs = concatMap inScope refs
where
mapRef = foldMap getScopeFromContext . identInfo . snd
scopes = case foldMap mapRef refs of
Just xs -> xs
Nothing -> []
inScope (sp, dets)
| definedInAsts asts n
&& any isOccurrence (identInfo dets)
= case scopes of
[] -> []
_ -> if any (`scopeContainsSpan` sp) scopes
then []
else return $ hsep
[ "Name", ppr n, "at position", ppr sp
, "doesn't occur in calculated scope", ppr scopes]
| otherwise = []

534
hie-compat/src-ghc86/Compat/HieTypes.hs
View File

@ -1,534 +0,0 @@
{-
Types for the .hie file format are defined here.
For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Compat.HieTypes where
import Config
import Binary
import FastString ( FastString )
import IfaceType
import Module ( ModuleName, Module )
import Name ( Name )
import Outputable hiding ( (<>) )
import SrcLoc
import Avail
import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.Set as S
import Data.ByteString ( ByteString )
import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
type Span = RealSrcSpan
instance Binary RealSrcSpan where
put_ bh ss = do
put_ bh (srcSpanFile ss)
put_ bh (srcSpanStartLine ss)
put_ bh (srcSpanStartCol ss)
put_ bh (srcSpanEndLine ss)
put_ bh (srcSpanEndCol ss)
get bh = do
f <- get bh
sl <- get bh
sc <- get bh
el <- get bh
ec <- get bh
return (mkRealSrcSpan (mkRealSrcLoc f sl sc)
(mkRealSrcLoc f el ec))
instance (A.Ix a, Binary a, Binary b) => Binary (A.Array a b) where
put_ bh arr = do
put_ bh $ A.bounds arr
put_ bh $ A.elems arr
get bh = do
bounds <- get bh
xs <- get bh
return $ A.listArray bounds xs
-- | Current version of @.hie@ files
hieVersion :: Integer
hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
{- |
GHC builds up a wealth of information about Haskell source as it compiles it.
@.hie@ files are a way of persisting some of this information to disk so that
external tools that need to work with haskell source don't need to parse,
typecheck, and rename all over again. These files contain:
* a simplified AST
* nodes are annotated with source positions and types
* identifiers are annotated with scope information
* the raw bytes of the initial Haskell source
Besides saving compilation cycles, @.hie@ files also offer a more stable
interface than the GHC API.
-}
data HieFile = HieFile
{ hie_hs_file :: FilePath
-- ^ Initial Haskell source file path
, hie_module :: Module
-- ^ The module this HIE file is for
, hie_types :: A.Array TypeIndex HieTypeFlat
-- ^ Types referenced in the 'hie_asts'.
--
-- See Note [Efficient serialization of redundant type info]
, hie_asts :: HieASTs TypeIndex
-- ^ Type-annotated abstract syntax trees
, hie_exports :: [AvailInfo]
-- ^ The names that this module exports
, hie_hs_src :: ByteString
-- ^ Raw bytes of the initial Haskell source
}
instance Binary HieFile where
put_ bh hf = do
put_ bh $ hie_hs_file hf
put_ bh $ hie_module hf
put_ bh $ hie_types hf
put_ bh $ hie_asts hf
put_ bh $ hie_exports hf
put_ bh $ hie_hs_src hf
get bh = HieFile
<$> get bh
<*> get bh
<*> get bh
<*> get bh
<*> get bh
<*> get bh
{-
Note [Efficient serialization of redundant type info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The type information in .hie files is highly repetitive and redundant. For
example, consider the expression
const True 'a'
There is a lot of shared structure between the types of subterms:
* const True 'a' :: Bool
* const True :: Char -> Bool
* const :: Bool -> Char -> Bool
Since all 3 of these types need to be stored in the .hie file, it is worth
making an effort to deduplicate this shared structure. The trick is to define
a new data type that is a flattened version of 'Type':
data HieType a = HAppTy a a -- data Type = AppTy Type Type
| HFunTy a a -- | FunTy Type Type
| ...
type TypeIndex = Int
Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',
where the 'TypeIndex's in the 'HieType' are references to other elements of the
array. Types recovered from GHC are deduplicated and stored in this compressed
form with sharing of subtrees.
-}
type TypeIndex = Int
-- | A flattened version of 'Type'.
--
-- See Note [Efficient serialization of redundant type info]
data HieType a
= HTyVarTy Name
| HAppTy a a
| HTyConApp IfaceTyCon (HieArgs a)
| HForAllTy ((Name, a),ArgFlag) a
| HFunTy a a
| HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')
| HLitTy IfaceTyLit
| HCastTy a
| HCoercionTy
deriving (Functor, Foldable, Traversable, Eq)
type HieTypeFlat = HieType TypeIndex
-- | Roughly isomorphic to the original core 'Type'.
newtype HieTypeFix = Roll (HieType HieTypeFix)
instance Binary (HieType TypeIndex) where
put_ bh (HTyVarTy n) = do
putByte bh 0
put_ bh n
put_ bh (HAppTy a b) = do
putByte bh 1
put_ bh a
put_ bh b
put_ bh (HTyConApp n xs) = do
putByte bh 2
put_ bh n
put_ bh xs
put_ bh (HForAllTy bndr a) = do
putByte bh 3
put_ bh bndr
put_ bh a
put_ bh (HFunTy a b) = do
putByte bh 4
put_ bh a
put_ bh b
put_ bh (HQualTy a b) = do
putByte bh 5
put_ bh a
put_ bh b
put_ bh (HLitTy l) = do
putByte bh 6
put_ bh l
put_ bh (HCastTy a) = do
putByte bh 7
put_ bh a
put_ bh HCoercionTy = putByte bh 8
get bh = do
(t :: Word8) <- get bh
case t of
0 -> HTyVarTy <$> get bh
1 -> HAppTy <$> get bh <*> get bh
2 -> HTyConApp <$> get bh <*> get bh
3 -> HForAllTy <$> get bh <*> get bh
4 -> HFunTy <$> get bh <*> get bh
5 -> HQualTy <$> get bh <*> get bh
6 -> HLitTy <$> get bh
7 -> HCastTy <$> get bh
8 -> return HCoercionTy
_ -> panic "Binary (HieArgs Int): invalid tag"
-- | A list of type arguments along with their respective visibilities (ie. is
-- this an argument that would return 'True' for 'isVisibleArgFlag'?).
newtype HieArgs a = HieArgs [(Bool,a)]
deriving (Functor, Foldable, Traversable, Eq)
instance Binary (HieArgs TypeIndex) where
put_ bh (HieArgs xs) = put_ bh xs
get bh = HieArgs <$> get bh
-- | Mapping from filepaths (represented using 'FastString') to the
-- corresponding AST
newtype HieASTs a = HieASTs { getAsts :: M.Map FastString (HieAST a) }
deriving (Functor, Foldable, Traversable)
instance Binary (HieASTs TypeIndex) where
put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
data HieAST a =
Node
{ nodeInfo :: NodeInfo a
, nodeSpan :: Span
, nodeChildren :: [HieAST a]
} deriving (Functor, Foldable, Traversable)
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
put_ bh $ nodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
get bh = Node
<$> get bh
<*> get bh
<*> get bh
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
-- (see Note [Efficient serialization of redundant type info]).
data NodeInfo a = NodeInfo
{ nodeAnnotations :: S.Set (FastString,FastString)
-- ^ (name of the AST node constructor, name of the AST node Type)
, nodeType :: [a]
-- ^ The Haskell types of this node, if any.
, nodeIdentifiers :: NodeIdentifiers a
-- ^ All the identifiers and their details
} deriving (Functor, Foldable, Traversable)
instance Binary (NodeInfo TypeIndex) where
put_ bh ni = do
put_ bh $ S.toAscList $ nodeAnnotations ni
put_ bh $ nodeType ni
put_ bh $ M.toList $ nodeIdentifiers ni
get bh = NodeInfo
<$> fmap S.fromDistinctAscList (get bh)
<*> get bh
<*> fmap M.fromList (get bh)
type Identifier = Either ModuleName Name
type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
-- | Information associated with every identifier
--
-- We need to include types with identifiers because sometimes multiple
-- identifiers occur in the same span(Overloaded Record Fields and so on)
data IdentifierDetails a = IdentifierDetails
{ identType :: Maybe a
, identInfo :: S.Set ContextInfo
} deriving (Eq, Functor, Foldable, Traversable)
instance Outputable a => Outputable (IdentifierDetails a) where
ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)
instance Semigroup (IdentifierDetails a) where
d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
(S.union (identInfo d1) (identInfo d2))
instance Monoid (IdentifierDetails a) where
mempty = IdentifierDetails Nothing S.empty
instance Binary (IdentifierDetails TypeIndex) where
put_ bh dets = do
put_ bh $ identType dets
put_ bh $ S.toAscList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
<*> fmap S.fromDistinctAscList (get bh)
-- | Different contexts under which identifiers exist
data ContextInfo
= Use -- ^ regular variable
| MatchBind
| IEThing IEType -- ^ import/export
| TyDecl
-- | Value binding
| ValBind
BindType -- ^ whether or not the binding is in an instance
Scope -- ^ scope over which the value is bound
(Maybe Span) -- ^ span of entire binding
-- | Pattern binding
--
-- This case is tricky because the bound identifier can be used in two
-- distinct scopes. Consider the following example (with @-XViewPatterns@)
--
-- @
-- do (b, a, (a -> True)) <- bar
-- foo a
-- @
--
-- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and
-- in the rest of the @do@-block in @foo a@.
| PatternBind
Scope -- ^ scope /in the pattern/ (the variable bound can be used
-- further in the pattern)
Scope -- ^ rest of the scope outside the pattern
(Maybe Span) -- ^ span of entire binding
| ClassTyDecl (Maybe Span)
-- | Declaration
| Decl
DeclType -- ^ type of declaration
(Maybe Span) -- ^ span of entire binding
-- | Type variable
| TyVarBind Scope TyVarScope
-- | Record field
| RecField RecFieldContext (Maybe Span)
deriving (Eq, Ord, Show)
instance Outputable ContextInfo where
ppr = text . show
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
put_ bh (IEThing t) = do
putByte bh 1
put_ bh t
put_ bh TyDecl = putByte bh 2
put_ bh (ValBind bt sc msp) = do
putByte bh 3
put_ bh bt
put_ bh sc
put_ bh msp
put_ bh (PatternBind a b c) = do
putByte bh 4
put_ bh a
put_ bh b
put_ bh c
put_ bh (ClassTyDecl sp) = do
putByte bh 5
put_ bh sp
put_ bh (Decl a b) = do
putByte bh 6
put_ bh a
put_ bh b
put_ bh (TyVarBind a b) = do
putByte bh 7
put_ bh a
put_ bh b
put_ bh (RecField a b) = do
putByte bh 8
put_ bh a
put_ bh b
put_ bh MatchBind = putByte bh 9
get bh = do
(t :: Word8) <- get bh
case t of
0 -> return Use
1 -> IEThing <$> get bh
2 -> return TyDecl
3 -> ValBind <$> get bh <*> get bh <*> get bh
4 -> PatternBind <$> get bh <*> get bh <*> get bh
5 -> ClassTyDecl <$> get bh
6 -> Decl <$> get bh <*> get bh
7 -> TyVarBind <$> get bh <*> get bh
8 -> RecField <$> get bh <*> get bh
9 -> return MatchBind
_ -> panic "Binary ContextInfo: invalid tag"
-- | Types of imports and exports
data IEType
= Import
| ImportAs
| ImportHiding
| Export
deriving (Eq, Enum, Ord, Show)
instance Binary IEType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)
data RecFieldContext
= RecFieldDecl
| RecFieldAssign
| RecFieldMatch
| RecFieldOcc
deriving (Eq, Enum, Ord, Show)
instance Binary RecFieldContext where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)
data BindType
= RegularBind
| InstanceBind
deriving (Eq, Ord, Show, Enum)
instance Binary BindType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)
data DeclType
= FamDec -- ^ type or data family
| SynDec -- ^ type synonym
| DataDec -- ^ data declaration
| ConDec -- ^ constructor declaration
| PatSynDec -- ^ pattern synonym
| ClassDec -- ^ class declaration
| InstDec -- ^ instance declaration
deriving (Eq, Ord, Show, Enum)
instance Binary DeclType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! toEnum (fromIntegral x)
data Scope
= NoScope
| LocalScope Span
| ModuleScope
deriving (Eq, Ord, Show, Typeable, Data)
instance Outputable Scope where
ppr NoScope = text "NoScope"
ppr (LocalScope sp) = text "LocalScope" <+> ppr sp
ppr ModuleScope = text "ModuleScope"
instance Binary Scope where
put_ bh NoScope = putByte bh 0
put_ bh (LocalScope span) = do
putByte bh 1
put_ bh span
put_ bh ModuleScope = putByte bh 2
get bh = do
(t :: Word8) <- get bh
case t of
0 -> return NoScope
1 -> LocalScope <$> get bh
2 -> return ModuleScope
_ -> panic "Binary Scope: invalid tag"
-- | Scope of a type variable.
--
-- This warrants a data type apart from 'Scope' because of complexities
-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For
-- example, consider:
--
-- @
-- foo, bar, baz :: forall a. a -> a
-- @
--
-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we
-- need a list of scopes to keep track of this. Furthermore, this list cannot be
-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.
--
-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@
-- which later gets resolved into a 'ResolvedScopes'.
data TyVarScope
= ResolvedScopes [Scope]
-- | Unresolved scopes should never show up in the final @.hie@ file
| UnresolvedScope
[Name] -- ^ names of the definitions over which the scope spans
(Maybe Span) -- ^ the location of the instance/class declaration for
-- the case where the type variable is declared in a
-- method type signature
deriving (Eq, Ord)
instance Show TyVarScope where
show (ResolvedScopes sc) = show sc
show _ = error "UnresolvedScope"
instance Binary TyVarScope where
put_ bh (ResolvedScopes xs) = do
putByte bh 0
put_ bh xs
put_ bh (UnresolvedScope ns span) = do
putByte bh 1
put_ bh ns
put_ bh span
get bh = do
(t :: Word8) <- get bh
case t of
0 -> ResolvedScopes <$> get bh
1 -> UnresolvedScope <$> get bh <*> get bh
_ -> panic "Binary TyVarScope: invalid tag"

451
hie-compat/src-ghc86/Compat/HieUtils.hs
View File

@ -1,451 +0,0 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Compat.HieUtils where
import CoreMap
import DynFlags ( DynFlags )
import FastString ( FastString, mkFastString )
import IfaceType
import Name hiding (varName)
import Outputable ( renderWithStyle, ppr, defaultUserStyle )
import SrcLoc
import ToIface
import TyCon
import TyCoRep
import Type
import Var
import VarEnv
import Compat.HieTypes
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Array as A
import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )
import Data.Maybe ( maybeToList )
import Data.Monoid
import Data.Traversable ( for )
import Control.Monad.Trans.State.Strict hiding (get)
generateReferencesMap
:: Foldable f
=> f (HieAST a)
-> M.Map Identifier [(Span, IdentifierDetails a)]
generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
where
go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
where
this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
where sty = defaultUserStyle df
resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
resolveVisibility kind ty_args
= go (mkEmptyTCvSubst in_scope) kind ty_args
where
in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
go _ _ [] = []
go env ty ts
| Just ty' <- coreView ty
= go env ty' ts
go env (ForAllTy (TvBndr tv vis) res) (t:ts)
| isVisibleArgFlag vis = (True , t) : ts'
| otherwise = (False, t) : ts'
where
ts' = go (extendTvSubst env tv t) res ts
go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
= (True,t) : go env res ts
go env (TyVarTy tv) ts
| Just ki <- lookupTyVar env tv = go env ki ts
go env kind (t:ts) = (True, t) : go env kind ts -- Ill-kinded
foldType :: (HieType a -> a) -> HieTypeFix -> a
foldType f (Roll t) = f $ fmap (foldType f) t
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
where
go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
go (HAppTy a b) = IfaceAppTy a b
go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
in IfaceForAllTy (TvBndr b af) t
go (HFunTy a b) = IfaceFunTy a b
go (HQualTy pred b) = IfaceDFunTy pred b
go (HCastTy a) = a
go HCoercionTy = IfaceTyVar "<coercion type>"
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
-- This isn't fully faithful - we can't produce the 'Inferred' case
hieToIfaceArgs :: HieArgs IfaceType -> IfaceTcArgs
hieToIfaceArgs (HieArgs xs) = go' xs
where
go' [] = ITC_Nil
go' ((True ,x):xs) = ITC_Vis x $ go' xs
go' ((False,x):xs) = ITC_Invis x $ go' xs
data HieTypeState
= HTS
{ tyMap :: !(TypeMap TypeIndex)
, htyTable :: !(IM.IntMap HieTypeFlat)
, freshIndex :: !TypeIndex
}
initialHTS :: HieTypeState
initialHTS = HTS emptyTypeMap IM.empty 0
freshTypeIndex :: State HieTypeState TypeIndex
freshTypeIndex = do
index <- gets freshIndex
modify' $ \hts -> hts { freshIndex = index+1 }
return index
compressTypes
:: HieASTs Type
-> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
compressTypes asts = (a, arr)
where
(a, HTS _ m i) = flip runState initialHTS $
for asts $ \typ -> do
i <- getTypeIndex typ
return i
arr = A.array (0,i-1) (IM.toList m)
recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
recoverFullType i m = go i
where
go i = Roll $ fmap go (m A.! i)
getTypeIndex :: Type -> State HieTypeState TypeIndex
getTypeIndex t
= do
tm <- gets tyMap
case lookupTypeMap tm t of
Just i -> return i
Nothing -> do
ht <- go t
extendHTS t ht
where
extendHTS t ht = do
i <- freshTypeIndex
modify' $ \(HTS tm tt fi) ->
HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
return i
go (TyVarTy v) = return $ HTyVarTy $ varName v
go (AppTy a b) = do
ai <- getTypeIndex a
bi <- getTypeIndex b
return $ HAppTy ai bi
go (TyConApp f xs) = do
let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
is <- mapM getTypeIndex visArgs
return $ HTyConApp (toIfaceTyCon f) is
go (ForAllTy (TvBndr v a) t) = do
k <- getTypeIndex (varType v)
i <- getTypeIndex t
return $ HForAllTy ((varName v,k),a) i
go (FunTy a b) = do
ai <- getTypeIndex a
bi <- getTypeIndex b
return $ if isPredTy a
then HQualTy ai bi
else HFunTy ai bi
go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
go (CastTy t _) = do
i <- getTypeIndex t
return $ HCastTy i
go (CoercionTy _) = return HCoercionTy
resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
resolveTyVarScopes asts = M.map go asts
where
go ast = resolveTyVarScopeLocal ast asts
resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
resolveTyVarScopeLocal ast asts = go ast
where
resolveNameScope dets = dets{identInfo =
S.map resolveScope (identInfo dets)}
resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
TyVarBind sc $ ResolvedScopes
[ LocalScope binding
| name <- names
, Just binding <- [getNameBinding name asts]
]
resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
TyVarBind sc $ ResolvedScopes
[ LocalScope binding
| name <- names
, Just binding <- [getNameBindingInClass name sp asts]
]
resolveScope scope = scope
go (Node info span children) = Node info' span $ map go children
where
info' = info { nodeIdentifiers = idents }
idents = M.map resolveNameScope $ nodeIdentifiers info
getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
getNameBinding n asts = do
(_,msp) <- getNameScopeAndBinding n asts
msp
getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
getNameScope n asts = do
(scopes,_) <- getNameScopeAndBinding n asts
return scopes
getNameBindingInClass
:: Name
-> Span
-> M.Map FastString (HieAST a)
-> Maybe Span
getNameBindingInClass n sp asts = do
ast <- M.lookup (srcSpanFile sp) asts
getFirst $ foldMap First $ do
child <- flattenAst ast
dets <- maybeToList
$ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return (getFirst binding)
getNameScopeAndBinding
:: Name
-> M.Map FastString (HieAST a)
-> Maybe ([Scope], Maybe Span)
getNameScopeAndBinding n asts = case nameSrcSpan n of
RealSrcSpan sp -> do -- @Maybe
ast <- M.lookup (srcSpanFile sp) asts
defNode <- selectLargestContainedBy sp ast
getFirst $ foldMap First $ do -- @[]
node <- flattenAst defNode
dets <- maybeToList
$ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return $ Just (scopes, getFirst binding)
_ -> Nothing
getScopeFromContext :: ContextInfo -> Maybe [Scope]
getScopeFromContext (ValBind _ sc _) = Just [sc]
getScopeFromContext (PatternBind a b _) = Just [a, b]
getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
getScopeFromContext (Decl _ _) = Just [ModuleScope]
getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
getScopeFromContext (TyVarBind a _) = Just [a]
getScopeFromContext _ = Nothing
getBindSiteFromContext :: ContextInfo -> Maybe Span
getBindSiteFromContext (ValBind _ _ sp) = sp
getBindSiteFromContext (PatternBind _ _ sp) = sp
getBindSiteFromContext _ = Nothing
flattenAst :: HieAST a -> [HieAST a]
flattenAst n =
n : concatMap flattenAst (nodeChildren n)
smallestContainingSatisfying
:: Span
-> (HieAST a -> Bool)
-> HieAST a
-> Maybe (HieAST a)
smallestContainingSatisfying sp cond node
| nodeSpan node `containsSpan` sp = getFirst $ mconcat
[ foldMap (First . smallestContainingSatisfying sp cond) $
nodeChildren node
, First $ if cond node then Just node else Nothing
]
| sp `containsSpan` nodeSpan node = Nothing
| otherwise = Nothing
selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
selectLargestContainedBy sp node
| sp `containsSpan` nodeSpan node = Just node
| nodeSpan node `containsSpan` sp =
getFirst $ foldMap (First . selectLargestContainedBy sp) $
nodeChildren node
| otherwise = Nothing
selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
selectSmallestContaining sp node
| nodeSpan node `containsSpan` sp = getFirst $ mconcat
[ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
, First (Just node)
]
| sp `containsSpan` nodeSpan node = Nothing
| otherwise = Nothing
definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
definedInAsts asts n = case nameSrcSpan n of
RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts
_ -> False
isOccurrence :: ContextInfo -> Bool
isOccurrence Use = True
isOccurrence _ = False
scopeContainsSpan :: Scope -> Span -> Bool
scopeContainsSpan NoScope _ = False
scopeContainsSpan ModuleScope _ = True
scopeContainsSpan (LocalScope a) b = a `containsSpan` b
-- | One must contain the other. Leaf nodes cannot contain anything
combineAst :: HieAST Type -> HieAST Type -> HieAST Type
combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
| aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
| aSpn `containsSpan` bSpn = combineAst b a
combineAst a (Node xs span children) = Node xs span (insertAst a children)
-- | Insert an AST in a sorted list of disjoint Asts
insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst x = mergeAsts [x]
-- | Merge two nodes together.
--
-- Precondition and postcondition: elements in 'nodeType' are ordered.
combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
where
mergeSorted :: [Type] -> [Type] -> [Type]
mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
LT -> a : mergeSorted as lb
EQ -> a : mergeSorted as bs
GT -> b : mergeSorted la bs
mergeSorted as [] = as
mergeSorted [] bs = bs
{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
different nodes in an AST tree should either have disjoint spans (in
which case you can say for sure which one comes first) or one span
should be completely contained in the other (in which case the contained
span corresponds to some child node).
However, since Haskell does have position-altering pragmas it /is/
possible for spans to be overlapping. Here is an example of a source file
in which @foozball@ and @quuuuuux@ have overlapping spans:
@
module Baz where
# line 3 "Baz.hs"
foozball :: Int
foozball = 0
# line 3 "Baz.hs"
bar, quuuuuux :: Int
bar = 1
quuuuuux = 2
@
In these cases, we just do our best to produce sensible `HieAST`'s. The blame
should be laid at the feet of whoever wrote the line pragmas in the first place
(usually the C preprocessor...).
-}
mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
mergeAsts xs [] = xs
mergeAsts [] ys = ys
mergeAsts xs@(a:as) ys@(b:bs)
| span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs
| span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs)
| span_a `rightOf` span_b = b : mergeAsts xs bs
| span_a `leftOf` span_b = a : mergeAsts as ys
-- These cases are to work around ASTs that are not fully disjoint
| span_a `startsRightOf` span_b = b : mergeAsts as ys
| otherwise = a : mergeAsts as ys
where
span_a = nodeSpan a
span_b = nodeSpan b
rightOf :: Span -> Span -> Bool
rightOf s1 s2
= (srcSpanStartLine s1, srcSpanStartCol s1)
>= (srcSpanEndLine s2, srcSpanEndCol s2)
&& (srcSpanFile s1 == srcSpanFile s2)
leftOf :: Span -> Span -> Bool
leftOf s1 s2
= (srcSpanEndLine s1, srcSpanEndCol s1)
<= (srcSpanStartLine s2, srcSpanStartCol s2)
&& (srcSpanFile s1 == srcSpanFile s2)
startsRightOf :: Span -> Span -> Bool
startsRightOf s1 s2
= (srcSpanStartLine s1, srcSpanStartCol s1)
>= (srcSpanStartLine s2, srcSpanStartCol s2)
-- | combines and sorts ASTs using a merge sort
mergeSortAsts :: [HieAST Type] -> [HieAST Type]
mergeSortAsts = go . map pure
where
go [] = []
go [xs] = xs
go xss = go (mergePairs xss)
mergePairs [] = []
mergePairs [xs] = [xs]
mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
simpleNodeInfo :: FastString -> FastString -> NodeInfo a
simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
locOnly :: SrcSpan -> [HieAST a]
locOnly (RealSrcSpan span) =
[Node e span []]
where e = NodeInfo S.empty [] M.empty
locOnly _ = []
mkScope :: SrcSpan -> Scope
mkScope (RealSrcSpan sp) = LocalScope sp
mkScope _ = NoScope
mkLScope :: Located a -> Scope
mkLScope = mkScope . getLoc
combineScopes :: Scope -> Scope -> Scope
combineScopes ModuleScope _ = ModuleScope
combineScopes _ ModuleScope = ModuleScope
combineScopes NoScope x = x
combineScopes x NoScope = x
combineScopes (LocalScope a) (LocalScope b) =
mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)
{-# INLINEABLE makeNode #-}
makeNode
:: (Applicative m, Data a)
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-> SrcSpan -- ^ return an empty list if this is unhelpful
-> m [HieAST b]
makeNode x spn = pure $ case spn of
RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]
_ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x
{-# INLINEABLE makeTypeNode #-}
makeTypeNode
:: (Applicative m, Data a)
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-> SrcSpan -- ^ return an empty list if this is unhelpful
-> Type -- ^ type to associate with the node
-> m [HieAST Type]
makeTypeNode x spn etyp = pure $ case spn of
RealSrcSpan span ->
[Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
_ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x

6
hls-graph/src/Development/IDE/Graph/Internal/Types.hs
View File

@ -12,11 +12,6 @@ module Development.IDE.Graph.Internal.Types where
import Control.Applicative
import Control.Monad.Catch
#if __GLASGOW_HASKELL__ < 808
import Control.Concurrent.STM.Stats (TVar, atomically)
#else
import GHC.Conc (TVar, atomically)
#endif
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Aeson (FromJSON, ToJSON)
@ -31,6 +26,7 @@ import Data.List (intercalate)
import Data.Maybe
import Data.Typeable
import Development.IDE.Graph.Classes
import GHC.Conc (TVar, atomically)
import GHC.Generics (Generic)
import qualified ListT
import qualified StmContainers.Map as SMap

9
plugins/hls-eval-plugin/test/Main.hs
View File

@ -140,13 +140,10 @@ tests =
, goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"
, goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs"
, testGroup "with preprocessors"
[ knownBrokenInEnv [HostOS Windows, GhcVer GHC86]
[ knownBrokenInEnv [HostOS Windows]
"CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $
goldenWithEval "CPP support" "TCPP" "hs"
, knownBrokenForGhcVersions [GHC86]
"Preprocessor known to fail on GHC <= 8.6" $
goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs"
-- , goldenWithEval "Literate Haskell LaTeX Style" "TLHSLateX" "lhs"
goldenWithEval "CPP support" "TCPP" "hs"
, goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs"
]
, goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs"
, goldenWithEval "Variable 'it' works" "TIt" "hs"

4
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs
View File

@ -306,11 +306,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
]
| L (locA -> l) r <- rds_rules,
pos `isInsideSrcSpan` l,
#if MIN_VERSION_ghc(8,8,0)
let HsRule {rd_name = L _ (_, rn)} = r,
#else
let HsRule _ (L _ (_,rn)) _ _ _ _ = r,
#endif
let ruleName = unpackFS rn
]
where

8
plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs
View File

@ -68,12 +68,12 @@ import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Prett
import qualified Development.IDE.Core.Shake as Shake
newtype Log
newtype Log
= LogShake Shake.Log
deriving Show
instance Pretty Log where
pretty = \case
pretty = \case
LogShake shakeLog -> pretty shakeLog
tacticDesc :: T.Text -> T.Text
@ -425,9 +425,7 @@ buildPatHy prov (fromPatCompat -> p0) =
mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5]
RecCon r ->
mkDerivedRecordHypothesis prov con args r
#if __GLASGOW_HASKELL__ >= 808
SigPat _ p _ -> buildPatHy prov p
#endif
#if __GLASGOW_HASKELL__ == 808
XPat p -> buildPatHy prov $ unLoc p
#endif
@ -585,7 +583,7 @@ wingmanRules recorder plId = do
#endif
| isHole occ ->
maybeToList $ srcSpanToRange span
#if __GLASGOW_HASKELL__ <= 808
#if __GLASGOW_HASKELL__ == 808
L span (EWildPat _) ->
maybeToList $ srcSpanToRange span
#endif

12
plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs
View File

@ -150,25 +150,13 @@ commandProvider Refine =
requireHoleSort (== Hole) $
provide Refine ""
commandProvider BeginMetaprogram =
requireGHC88OrHigher $
requireHoleSort (== Hole) $
provide BeginMetaprogram ""
commandProvider RunMetaprogram =
requireGHC88OrHigher $
withMetaprogram $ \mp ->
provide RunMetaprogram mp
requireGHC88OrHigher :: TacticProvider -> TacticProvider
#if __GLASGOW_HASKELL__ >= 808
requireGHC88OrHigher tp tpd =
tp tpd
#else
requireGHC88OrHigher _ _=
mempty
#endif
------------------------------------------------------------------------------
-- | Return an empty list if the given predicate doesn't hold over the length
guardLength :: (Int -> Bool) -> [a] -> [a]

8
plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs
View File

@ -14,7 +14,6 @@ import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes))
import Ide.Types
#if __GLASGOW_HASKELL__ >= 808
import Data.Data
import Generics.SYB
#if __GLASGOW_HASKELL__ >= 900
@ -22,7 +21,6 @@ import GHC.Driver.Plugins (purePlugin)
#else
import Plugins (purePlugin)
#endif
#endif
staticPlugin :: DynFlagsModifications
staticPlugin = mempty
@ -34,13 +32,9 @@ staticPlugin = mempty
{ refLevelHoleFits = Just 0
, maxRefHoleFits = Just 0
, maxValidHoleFits = Just 0
#if __GLASGOW_HASKELL__ >= 808
, staticPlugins = staticPlugins df <> [metaprogrammingPlugin]
#endif
}
#if __GLASGOW_HASKELL__ >= 808
, dynFlagsModifyParser = enableQuasiQuotes
#endif
}
@ -71,7 +65,6 @@ allowEmptyCaseButWithWarning =
flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns
#if __GLASGOW_HASKELL__ >= 808
metaprogrammingPlugin :: StaticPlugin
metaprogrammingPlugin =
StaticPlugin $ PluginWithArgs pluginDefinition []
@ -101,7 +94,6 @@ addMetaprogrammingSyntax =
L ss (MetaprogramSyntax mp) ->
L ss $ mkMetaprogram ss mp
(x :: LHsExpr GhcPs) -> x
#endif
metaprogramHoleName :: OccName
metaprogramHoleName = mkVarOcc "_$metaprogram"

6
plugins/hls-tactics-plugin/test/CodeAction/RunMetaprogramSpec.hs
View File

@ -11,17 +11,11 @@ import Wingman.Types
spec :: Spec
spec = do
let metaTest l c f =
#if __GLASGOW_HASKELL__ >= 808
goldenTest RunMetaprogram "" l c f
#else
pure ()
#endif
#if __GLASGOW_HASKELL__ >= 808
describe "beginMetaprogram" $ do
goldenTest BeginMetaprogram "" 1 7 "MetaBegin"
goldenTest BeginMetaprogram "" 1 9 "MetaBeginNoWildify"
#endif
describe "golden" $ do
metaTest 6 11 "MetaMaybeAp"

2
test/functional/Completion.hs
View File

@ -376,4 +376,4 @@ compls `shouldNotContainCompl` lbl =
@? "Should not contain completion: " ++ show lbl
expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree
expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC88, GHC86, GHC90]
expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC88, GHC90]