mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-10-26 09:20:16 +03:00
Cleanup GHC macros (because min version is 8.8.4) (#3281)
* 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:
parent
9b491f7bbf
commit
86e3fd6c65
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
||||
|
@ -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 ()
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -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"
|
@ -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 = []
|
@ -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"
|
@ -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
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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"
|
||||
|
@ -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"
|
||||
|
@ -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]
|
||||
|
Loading…
Reference in New Issue
Block a user