From 0953809fa5fccb455cbc6dbb4886e925d6d0bb26 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 29 Mar 2021 22:04:13 +0800 Subject: [PATCH 01/86] hie-compat: Add basic support for ghc-9.0.1 A tiny step towards #297 --- hie-compat/hie-compat.cabal | 12 +- hie-compat/src-ghc901/Compat/HieAst.hs | 2031 ++++++++++++++++++++++++ hie-compat/src-ghc901/Compat/HieBin.hs | 371 +++++ 3 files changed, 2411 insertions(+), 3 deletions(-) create mode 100644 hie-compat/src-ghc901/Compat/HieAst.hs create mode 100644 hie-compat/src-ghc901/Compat/HieBin.hs diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index 9778485028..9b1b5d2740 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -23,11 +23,15 @@ flag ghc-lib library default-language: Haskell2010 build-depends: - base < 4.15, array, bytestring, containers, directory, filepath, transformers + base < 4.16, array, bytestring, containers, directory, filepath, transformers if flag(ghc-lib) build-depends: ghc-lib else build-depends: ghc, ghc-boot + if (impl(ghc >= 9.0) && impl(ghc < 9.1)) + -- Used by src-reexport/... + build-depends: ghc-api-compat + ghc-options: -Wall -Wno-name-shadowing exposed-modules: Compat.HieAst @@ -38,8 +42,10 @@ library 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)) + 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) || flag(ghc-lib)) + if (impl(ghc > 8.9) && impl(ghc < 8.11)) hs-source-dirs: src-ghc810 src-reexport + if (impl(ghc >= 9.0) && impl(ghc < 9.1) || flag(ghc-lib)) + hs-source-dirs: src-ghc901 src-reexport diff --git a/hie-compat/src-ghc901/Compat/HieAst.hs b/hie-compat/src-ghc901/Compat/HieAst.hs new file mode 100644 index 0000000000..0b314f3d22 --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieAst.hs @@ -0,0 +1,2031 @@ +{- +Forked from GHC v9.0.1 to work around the readFile side effect in mkHiefile + +Main functions for .hie file generation +-} +{- HLINT ignore -} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Compat.HieAst ( mkHieFile, enrichHie ) where + +import GHC.Utils.Outputable(ppr) + +import GHC.Prelude + +import GHC.Types.Avail ( Avails ) +import GHC.Data.Bag ( Bag, bagToList ) +import GHC.Types.Basic +import GHC.Data.BooleanFormula +import GHC.Core.Class ( FunDep, className, classSCSelIds ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.FVs +import GHC.Core.DataCon ( dataConNonlinearType ) +import GHC.HsToCore ( deSugarExpr ) +import GHC.Types.FieldLabel +import GHC.Hs +import GHC.Driver.Types +import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Utils.Monad ( concatMapM, liftIO ) +import GHC.Types.Id ( isDataConId_maybe ) +import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.SrcLoc +import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) +import GHC.Core.Type ( mkVisFunTys, Type ) +import GHC.Core.Predicate +import GHC.Core.InstEnv +import GHC.Builtin.Types ( mkListTy, mkSumTy ) +import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) +import GHC.Types.Var.Env +import GHC.Types.Unique +import GHC.Iface.Make ( mkIfaceExports ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List ( foldl1' ) +import Control.Monad ( forM_ ) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +{- Note [Updating HieAst for changes in the GHC AST] + +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like + +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 + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in GHC.Iface.Ext.Ast. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in compiler/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +type VarMap a = DVarEnv (Var,a) +data HieState = HieState + { name_remapping :: NameEnv Id + , unlocated_ev_binds :: VarMap (S.Set ContextInfo) + -- These contain evidence bindings that we don't have a location for + -- These are placed at the top level Node in the HieAST after everything + -- else has been generated + -- This includes things like top level evidence bindings. + } + +addUnlocatedEvBind :: Var -> ContextInfo -> HieM () +addUnlocatedEvBind var ci = do + let go (a,b) (_,c) = (a,S.union b c) + lift $ modify' $ \s -> + s { unlocated_ev_binds = + extendDVarEnv_C go (unlocated_ev_binds s) + var (var,S.singleton ci) + } + +getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) +getUnlocatedEvBinds file = do + binds <- lift $ gets unlocated_ev_binds + org <- ask + let elts = dVarEnvElts binds + + mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) + + go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of + RealSrcSpan spn _ + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) + _ -> (mkNodeInfo e : xs,ys) + + (nis,asts) = foldr go ([],[]) elts + + pure $ (M.fromList nis, asts) + +initState :: HieState +initState = HieState emptyNameEnv emptyDVarEnv + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f + = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT NodeOrigin (StateT HieState Hsc) + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource + -> BS.ByteString -> Hsc HieFile +mkHieFile ms ts rs src = do + let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) + mkHieFileWithSource src_file src ms ts rs + +-- | Construct an 'HieFile' from the outputs of the typechecker but don't +-- read the source file again from disk. +mkHieFileWithSource :: FilePath + -> BS.ByteString + -> ModSummary + -> TcGblEnv + -> RenamedSource -> Hsc HieFile +mkHieFileWithSource src_file src ms ts rs = do + let tc_binds = tcg_binds ts + top_ev_binds = tcg_ev_binds ts + insts = tcg_insts ts + tcs = tcg_tcs ts + (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs top_ev_binds insts tcs = do + asts <- enrichHie ts rs top_ev_binds insts tcs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = + flip evalStateT initState $ flip runReaderT SourceInfo $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + -- Add Instance bindings + forM_ insts $ \i -> + addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) + -- Add class parent bindings + forM_ tcs $ \tc -> + case tyConClass_maybe tc of + Nothing -> pure () + Just c -> forM_ (classSCSelIds c) $ \v -> + addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) + let spanFile file children = case children of + [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + + modulify file xs' = do + + top_ev_asts <- + toHie $ EvBindContext ModuleScope Nothing + $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) + $ EvBinds ev_bs + + (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file + + let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts + span = spanFile file xs + + moduleInfo = SourcedNodeInfo + $ M.singleton SourceInfo + $ (simpleNodeInfo "Module" "Module") + {nodeIdentifiers = uloc_evs} + + moduleNode = Node moduleInfo span [] + + case mergeSortAsts $ moduleNode : xs of + [x] -> return x + xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) + + asts' <- sequence + $ M.mapWithKey modulify + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + let asts = HieASTs $ resolveTyVarScopes asts' + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = panic "XGRHS has no span" + +bindingsOnly :: [Context Name] -> HieM [HieAST a] +bindingsOnly [] = pure [] +bindingsOnly (C c n : xs) = do + org <- ask + rest <- bindingsOnly xs + pure $ case nameSrcSpan n of + RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> rest + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local transformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data EvBindContext a = EvBindContext Scope (Maybe Span) a + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr flag a] + -> [TVScoped (LHsTyVarBndr flag a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here + +This case in handled in the instance for HsPatSigType +-} + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance HasLoc a => HasLoc (FamEqn s a) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + +{- Note [Real DataCon Name] +The typechecker substitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span _) mname)) = do + org <- ask + pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | varUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConNonlinearType dc + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just ty) + (S.singleton context))) + span + []] + C (EvidenceVarBind i _ sp) (L _ name) -> do + addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) + pure [] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +evVarsOfTermList :: EvTerm -> [EvId] +evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e +evVarsOfTermList (EvTypeable _ ev) = + case ev of + EvTypeableTyCon _ e -> concatMap evVarsOfTermList e + EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] + EvTypeableTyLit e -> evVarsOfTermList e +evVarsOfTermList (EvFun{}) = [] + +instance ToHie (EvBindContext (Located TcEvBinds)) where + toHie (EvBindContext sc sp (L span (EvBinds bs))) + = concatMapM go $ bagToList bs + where + go evbind = do + let evDeps = evVarsOfTermList $ eb_rhs evbind + depNames = EvBindDeps $ map varName evDeps + concatM $ + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + (L span $ eb_lhs evbind)) + , toHie $ map (C EvidenceVarUse . L span) $ evDeps + ] + toHie _ = pure [] + +instance ToHie (Located HsWrapper) where + toHie (L osp wrap) + = case wrap of + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) + (WpCompose a b) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpFun a b _ _) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpEvLam a) -> + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) + $ L osp a + (WpEvApp a) -> + concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + _ -> pure [] + +instance HiePass p => HasType (LHsBind (GhcPass p)) where + getTypeNode (L spn bind) = + case hiePass @p of + HieRn -> makeNode bind spn + HieTc -> case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HiePass p => HasType (Located (Pat (GhcPass p))) where + getTypeNode (L spn pat) = + case hiePass @p of + HieRn -> makeNode pat spn + HieTc -> makeTypeNode pat spn (hsPatType pat) + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HiePass p => HasType (LHsExpr (GhcPass p)) where + getTypeNode e@(L spn e') = + case hiePass @p of + HieRn -> makeNode e' spn + HieTc -> + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr GhcTc -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (WrapExpr {}) -> False + _ -> True + +data HiePassEv p where + HieRn :: HiePassEv 'Renamed + HieTc :: HiePassEv 'Typechecked + +class ( IsPass p + , HiePass (NoGhcTcPass p) + , ModifyState (IdGhcP p) + , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) + , Data (HsExpr (GhcPass p)) + , Data (HsCmd (GhcPass p)) + , Data (AmbiguousFieldOcc (GhcPass p)) + , Data (HsCmdTop (GhcPass p)) + , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) + , Data (HsSplice (GhcPass p)) + , Data (HsLocalBinds (GhcPass p)) + , Data (FieldOcc (GhcPass p)) + , Data (HsTupArg (GhcPass p)) + , Data (IPBind (GhcPass p)) + , ToHie (Context (Located (IdGhcP p))) + , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) + , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) + , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) + , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , HasRealDataConName (GhcPass p) + ) + => HiePass p where + hiePass :: HiePassEv p + +instance HiePass 'Renamed where + hiePass = HieRn +instance HiePass 'Typechecked where + hiePass = HieTc + +instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + , case hiePass @p of + HieTc -> toHie $ L span wrap + _ -> pure [] + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{ abs_exports = xs, abs_binds = binds + , abs_ev_binds = ev_binds + , abs_ev_vars = ev_vars } -> + [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] + (toHie $ fmap (BC context scope) binds) + , toHie $ map (L span . abe_wrap) xs + , toHie $ + map (EvBindContext (mkScope span) (getRealSpan span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScope span) + (getRealSpan span)) + . L span) ev_vars + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + +instance ( HiePass p + , ToHie (Located body) + , Data body + ) => ToHie (MatchGroup (GhcPass p) (Located body)) where + toHie mg = case mg of + MG{ mg_alts = (L span alts) , mg_origin = origin} -> + local (setOrigin origin) $ concatM + [ locOnly span + , toHie alts + ] + +setOrigin :: Origin -> NodeOrigin -> NodeOrigin +setOrigin FromSource _ = SourceInfo +setOrigin Generated _ = GeneratedInfo + +instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope patScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + patScope = mkScope $ getLoc pat + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + +instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( HiePass p + , Data body + , ToHie (Located body) + ) => ToHie (LMatch (GhcPass p) (Located body)) where + toHie (L span m ) = concatM $ node : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + where + node = case hiePass @p of + HieTc -> makeNode m span + HieRn -> makeNode m span + +instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> + case hiePass @p of + HieTc -> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + , let ev_binds = cpt_binds ext + ev_vars = cpt_dicts ext + wrap = cpt_wrap ext + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds + , toHie $ L ospan wrap + , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) + . L ospan) ev_vars + ] + ] + HieRn -> + [ toHie $ C Use con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , case hiePass @p of + HieTc -> + let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + sig + HieRn -> pure [] + ] + XPat e -> + case hiePass @p of + HieTc -> + let CoPat wrap pat _ = e + in [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] +#if __GLASGOW_HASKELL__ < 811 + HieRn -> [] +#endif + where + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + + +instance ToHie (TScoped (HsPatSigType GhcRn)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + , toHie body + ] + -- See Note [Scoping Rules for SigPat] + +instance ( ToHie (Located body) + , HiePass p + , Data body + ) => ToHie (GRHSs (GhcPass p) (Located body)) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + +instance ( ToHie (Located body) + , HiePass a + , Data body + ) => ToHie (LGRHS (GhcPass a) (Located body)) where + toHie (L span g) = concatM $ node : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + where + node = case hiePass @a of + HieRn -> makeNode g span + HieTc -> makeNode g span + +instance HiePass p => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) + -- See Note [Real DataCon Name] + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsPragE _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ _wrap b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + XExpr x + | GhcTc <- ghcPass @p + , WrapExpr (HsWrap w a) <- x + -> [ toHie $ L mspan a + , toHie (L mspan w) + ] + | GhcTc <- ghcPass @p + , ExpansionExpr (HsExpanded _ b) <- x + -> [ toHie (L mspan b) + ] + | otherwise -> [] + +instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + +instance ( ToHie (Located body) + , Data body + , HiePass p + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ node : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + where + node = case hiePass @p of + HieTc -> makeNode stmt span + HieRn -> makeNode stmt span + +instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ ipbinds -> case ipbinds of + IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in + [ case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds + HieRn -> pure [] + , toHie $ map (RS sc) xs + ] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + +instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where + toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of + IPBind _ (Left _) expr -> [toHie expr] + IPBind _ (Right v) expr -> + [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) + $ L sp v + , toHie expr + ] + +instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie arg , HasLoc arg , Data arg + , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg , HasLoc arg , Data arg + , Data label + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan name) + ] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan name + ] + Ambiguous _name _ -> + [ ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + Ambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + +instance HiePass p => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdLamCase _ alts -> + [ toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (locOnly . getLoc) deftyps + , toHie deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie rhs, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn rhs)) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = locOnly span + +instance ToHie a => ToHie (HsScaled GhcRn a) where + toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , concatM $ [ bindingsOnly bindings + , toHie $ tvScopes resScope NoScope exp_vars ] + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + resScope = ResolvedScopes [ctxScope, rhsScope] + bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + where condecl_scope :: HsConDeclDetails p -> Scope + condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs + InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) + (mkLScope (hsScaledThing b)) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + +instance ToHie (LStandaloneKindSig GhcRn) where + toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + +instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where + toHie (SC (SI styp msp) (L sp sig)) = + case hiePass @p of + HieTc -> pure [] + HieRn -> concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , maybe (pure []) (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ tele body -> + let scope = mkScope $ getLoc body in + [ case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ w a b -> + [ toHie (arrowToHsType w) + , toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = locOnly sp + +instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + XSplice x -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon x + GhcRn -> noExtCon x +#endif + GhcTc -> case x of + HsSplicedT _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (locOnly . getLoc) roles + ] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = concatM $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + where + goIE (hiding, (L sp liens)) = concatM $ + [ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] diff --git a/hie-compat/src-ghc901/Compat/HieBin.hs b/hie-compat/src-ghc901/Compat/HieBin.hs new file mode 100644 index 0000000000..75989759db --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieBin.hs @@ -0,0 +1,371 @@ +{- +Binary serialization for .hie files. +-} +{- HLINT ignore -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +module Compat.HieBin + ( readHieFile + , readHieFileWithVersion + , HieHeader + , writeHieFile + , HieName(..) + , toHieName + , HieFileResult(..) + , hieMagic + , hieNameOcc + , NameCacheUpdater(..) + ) +where + +import GHC.Settings.Utils ( maybeRead ) +import GHC.Settings.Config ( cProjectVersion ) +-- import GHC.Prelude +import GHC.Utils.Binary +import GHC.Iface.Binary ( getDictFastString ) +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply ( takeUniqFromSupply ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Iface.Env (NameCacheUpdater(..)) +-- 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 GHC.Iface.Ext.Types + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM FastString (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 initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) + 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_Directly 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_Directly out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM Name (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 + +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 "GHC.Iface.Ext.Binary.getHieName: invalid tag" From 4d90153f533aab85fddedcc9d63a31ad3f3cddc1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 29 Mar 2021 22:17:34 +0800 Subject: [PATCH 02/86] hie-compat: Remove dependency on ghc-api-compat --- hie-compat/hie-compat.cabal | 4 +--- hie-compat/src-ghc901/Compat/HieDebug.hs | 3 +++ hie-compat/src-ghc901/Compat/HieTypes.hs | 3 +++ hie-compat/src-ghc901/Compat/HieUtils.hs | 3 +++ 4 files changed, 10 insertions(+), 3 deletions(-) create mode 100644 hie-compat/src-ghc901/Compat/HieDebug.hs create mode 100644 hie-compat/src-ghc901/Compat/HieTypes.hs create mode 100644 hie-compat/src-ghc901/Compat/HieUtils.hs diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index 9b1b5d2740..7ceccc51ab 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -29,8 +29,6 @@ library else build-depends: ghc, ghc-boot if (impl(ghc >= 9.0) && impl(ghc < 9.1)) - -- Used by src-reexport/... - build-depends: ghc-api-compat ghc-options: -Wall -Wno-name-shadowing exposed-modules: @@ -47,5 +45,5 @@ library if (impl(ghc > 8.9) && impl(ghc < 8.11)) hs-source-dirs: src-ghc810 src-reexport if (impl(ghc >= 9.0) && impl(ghc < 9.1) || flag(ghc-lib)) - hs-source-dirs: src-ghc901 src-reexport + hs-source-dirs: src-ghc901 diff --git a/hie-compat/src-ghc901/Compat/HieDebug.hs b/hie-compat/src-ghc901/Compat/HieDebug.hs new file mode 100644 index 0000000000..9b8281c2bc --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieDebug.hs @@ -0,0 +1,3 @@ +module Compat.HieDebug + ( module GHC.Iface.Ext.Debug ) where +import GHC.Iface.Ext.Debug diff --git a/hie-compat/src-ghc901/Compat/HieTypes.hs b/hie-compat/src-ghc901/Compat/HieTypes.hs new file mode 100644 index 0000000000..36bb86abeb --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieTypes.hs @@ -0,0 +1,3 @@ +module Compat.HieTypes + ( module GHC.Iface.Ext.Types ) where +import GHC.Iface.Ext.Types diff --git a/hie-compat/src-ghc901/Compat/HieUtils.hs b/hie-compat/src-ghc901/Compat/HieUtils.hs new file mode 100644 index 0000000000..204a312039 --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieUtils.hs @@ -0,0 +1,3 @@ +module Compat.HieUtils + ( module GHC.Iface.Ext.Utils ) where +import GHC.Iface.Ext.Utils From d21dc8f8c5c99787f58df5c17051adee36c58e6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 12:14:20 +0800 Subject: [PATCH 03/86] hie-compat: Add more backwards compatability --- hie-compat/src-ghc901/Compat/HieDebug.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/hie-compat/src-ghc901/Compat/HieDebug.hs b/hie-compat/src-ghc901/Compat/HieDebug.hs index 9b8281c2bc..872da67c2b 100644 --- a/hie-compat/src-ghc901/Compat/HieDebug.hs +++ b/hie-compat/src-ghc901/Compat/HieDebug.hs @@ -1,3 +1,10 @@ module Compat.HieDebug - ( module GHC.Iface.Ext.Debug ) where + ( module GHC.Iface.Ext.Debug + , ppHie ) where import GHC.Iface.Ext.Debug + +import GHC.Iface.Ext.Types (HieAST) +import GHC.Utils.Outputable (Outputable(ppr), SDoc) + +ppHie :: Outputable a => HieAST a -> SDoc +ppHie = ppr From 24d0de6699b42de1de9237d5a8e681fb5a888589 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 16:45:11 +0800 Subject: [PATCH 04/86] Import a bunch of upstream ghc9 fixes --- cabal.project | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 60 insertions(+) diff --git a/cabal.project b/cabal.project index b82db73bcb..86dc34a3d5 100644 --- a/cabal.project +++ b/cabal.project @@ -23,6 +23,66 @@ package * ghc-options: -haddock test-show-details: direct +source-repository-package + type: git + location: https://github.com/jwaldmann/blaze-textual.git + tag: d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/bos/blaze-textual/issues/13 + +source-repository-package + type: git + location: https://github.com/mithrandi/czipwith.git + tag: b6245884ae83e00dd2b5261762549b37390179f8 + -- https://github.com/lspitzner/czipwith/pull/2 + + +source-repository-package + type: git + location: https://github.com/jneira/hie-bios/ + tag: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 + -- https://github.com/mpickering/hie-bios/pull/285 + +source-repository-package + type: git + location: https://github.com/hsyl20/ghc-api-compat + tag: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 + +source-repository-package + type: git + location: https://github.com/anka-213/th-extras + tag: 57a97b4df128eb7b360e8ab9c5759392de8d1659 +-- https://github.com/mokus0/th-extras/pull/8 +-- https://github.com/mokus0/th-extras/issues/7 + +source-repository-package + type: git + location: https://github.com/anka-213/ghc-check + tag: 63e01825772e06aa6c6f7032f30bfc2b1c88e7d2 +-- https://github.com/pepeiborra/ghc-check/pull/12 + +source-repository-package + type: git + location: https://github.com/anka-213/dependent-sum + tag: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + subdir: dependent-sum-template +-- https://github.com/obsidiansystems/dependent-sum/pull/57 + +source-repository-package + type: git + location: https://github.com/anka-213/HieDb + tag: a3f7521f6c5af1b977040cce09c8f7354f8984eb +-- https://github.com/wz1000/HieDb/pull/31 + +source-repository-package + type: git + location: https://github.com/anka-213/lsp + tag: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee + subdir: lsp-types + subdir: lsp + subdir: lsp-test +-- https://github.com/haskell/lsp/pull/312/commits/3bf244fe0cf7ca9b895ae71fb526adba466ceaee + write-ghc-environment-files: never index-state: 2021-03-29T21:23:14Z From f915936837a5211fd65c75450c77948b5a5093b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 16:46:22 +0800 Subject: [PATCH 05/86] cabal.project: allow-newer: *:* The lazy solution to making things compile --- cabal.project | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal.project b/cabal.project index 86dc34a3d5..adb5dcee0d 100644 --- a/cabal.project +++ b/cabal.project @@ -88,6 +88,7 @@ write-ghc-environment-files: never index-state: 2021-03-29T21:23:14Z allow-newer: + *:*, active:base, data-tree-print:base, diagrams-contrib:base, From 4ceaed73a471cc9e6fd418e2d8faefc87c3f3777 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 17:20:52 +0800 Subject: [PATCH 06/86] Add more upstream fixes --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index adb5dcee0d..ce60946945 100644 --- a/cabal.project +++ b/cabal.project @@ -83,6 +83,12 @@ source-repository-package subdir: lsp-test -- https://github.com/haskell/lsp/pull/312/commits/3bf244fe0cf7ca9b895ae71fb526adba466ceaee +source-repository-package + type: git + location: https://github.com/mpickering/apply-refact + tag: 0.9.2.0 +-- https://github.com/mpickering/apply-refact/issues/107 + write-ghc-environment-files: never index-state: 2021-03-29T21:23:14Z From 46d7e09f7677479c82cb87eb646a6dbcf7036ea7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 21:27:05 +0800 Subject: [PATCH 07/86] Bump patch of ghc-check --- cabal.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index ce60946945..62fcddf3f0 100644 --- a/cabal.project +++ b/cabal.project @@ -58,7 +58,7 @@ source-repository-package source-repository-package type: git location: https://github.com/anka-213/ghc-check - tag: 63e01825772e06aa6c6f7032f30bfc2b1c88e7d2 + tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d -- https://github.com/pepeiborra/ghc-check/pull/12 source-repository-package From 49fc015d645f3da596d210d495ac8bc5a8b5a963 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 1 Apr 2021 12:32:55 +0800 Subject: [PATCH 08/86] ghcide: Add basic support for GHC-9.0.1 I tried to limit the use of CPP to the Compat module as much as possible by re-exporting the new functions under the old names, but there is still plenty of pragmas all over the code. I'm using ghc-api-compat so the imports doesn't need to be changed as much. --- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 15 +- ghcide/src/Development/IDE/Core/Compile.hs | 53 +++- .../src/Development/IDE/Core/Preprocessor.hs | 7 +- ghcide/src/Development/IDE/Core/Shake.hs | 2 + ghcide/src/Development/IDE/GHC/CPP.hs | 7 +- ghcide/src/Development/IDE/GHC/Compat.hs | 249 +++++++++++++++++- ghcide/src/Development/IDE/GHC/Error.hs | 21 +- ghcide/src/Development/IDE/GHC/Orphans.hs | 32 ++- ghcide/src/Development/IDE/GHC/Util.hs | 26 +- ghcide/src/Development/IDE/GHC/Warnings.hs | 10 +- .../src/Development/IDE/Import/FindImports.hs | 8 +- ghcide/src/Development/IDE/LSP/Outline.hs | 44 ++-- .../src/Development/IDE/Plugin/CodeAction.hs | 28 +- .../src/Development/IDE/Plugin/Completions.hs | 4 + .../IDE/Plugin/Completions/Logic.hs | 13 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 6 + ghcide/src/Development/IDE/Spans/AtPoint.hs | 23 +- ghcide/src/Development/IDE/Spans/Common.hs | 6 +- .../Development/IDE/Spans/Documentation.hs | 23 +- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 15 +- ghcide/src/Development/IDE/Types/Options.hs | 7 +- 22 files changed, 468 insertions(+), 132 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 216fb1f5f0..e9c52070cd 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -98,6 +98,7 @@ library ghc >= 8.6, ghc-check >=0.5.0.1, ghc-paths, + ghc-api-compat, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios >= 0.7.1 && < 0.8.0, implicit-hie-cradle >= 0.3.0.2 && < 0.4, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3c776cb36b..932babab5b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -79,7 +79,6 @@ import HscTypes (hsc_IC, hsc_NC, import Linker import Module import NameCache -import Packages import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue @@ -108,7 +107,7 @@ data SessionLoadingOptions = SessionLoadingOptions , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: IO (Maybe LibDir) - , fakeUid :: InstalledUnitId + , fakeUid :: GHC.InstalledUnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the @@ -121,7 +120,7 @@ instance Default SessionLoadingOptions where ,loadCradle = HieBios.loadCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault - ,fakeUid = toInstalledUnitId (stringToUnitId "main") + ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main") } getInitialGhcLibDirDefault :: IO (Maybe LibDir) @@ -731,12 +730,12 @@ removeInplacePackages -> [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) -removeInplacePackages fake_uid us df = (df { packageFlags = ps - , thisInstalledUnitId = fake_uid }, uids) +removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $ + df { packageFlags = ps }, uids) where (uids, ps) = partitionEithers (map go (packageFlags df)) - go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us - then Left (toInstalledUnitId u) + go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us + then Left (GHC.toInstalledUnitId u) else Right p go p = Right p @@ -778,7 +777,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied. - (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' + final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags'' return (final_df, targets) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index ff8f5f1c0c..273ab35098 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -81,7 +81,15 @@ import MkIface import StringBuffer as SB import TcIface (typecheckIface) import TcRnMonad hiding (newUnique) +#if MIN_GHC_API_VERSION(9,0,1) +import GHC.Builtin.Names +import GHC.Iface.Recomp +import GHC.Tc.Gen.Splice +import GHC.Tc.Types.Evidence (EvBind) +#else +import PrelNames import TcSplice +#endif import TidyPgm import Bag @@ -104,7 +112,6 @@ import qualified GHC.LanguageExtensions as LangExt import HeaderInfo import Linker (unload) import Maybes (orElse) -import PrelNames import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) @@ -144,10 +151,10 @@ computePackageDeps -> IO (Either [FileDiagnostic] [InstalledUnitId]) computePackageDeps env pkg = do let dflags = hsc_dflags env - case lookupInstalledPackage dflags pkg of + case oldLookupInstalledPackage dflags pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] - Just pkgInfo -> return $ Right $ depends pkgInfo + Just pkgInfo -> return $ Right $ unitDepends pkgInfo typecheckModule :: IdeDefer -> HscEnv @@ -268,7 +275,10 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do (guts, details) <- tidyProgram session simplified_guts (diags, linkable) <- genLinkable session ms guts pure (linkable, details, diags) -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_GHC_API_VERSION(9,0,1) + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface <- mkFullIface session partial_iface Nothing +#elif MIN_GHC_API_VERSION(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface #else @@ -336,7 +346,11 @@ generateObjectCode session summary guts = do target = defaultObjectTarget $ targetPlatform $ hsc_dflags session #endif session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} +#if MIN_GHC_API_VERSION(9,0,1) + (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts +#else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts +#endif #if MIN_GHC_API_VERSION(8,10,0) (ms_location summary') #else @@ -464,7 +478,15 @@ generateHieAsts hscEnv tcm = -- don't export an interface which allows for additional information to be added to hie files. let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm +#if MIN_GHC_API_VERSION(9,0,1) + -- TODO: Use some proper values here! + evBinds = emptyBag @EvBind :: Bag EvBind + clsInsts = [] :: [ClsInst] + tyCons = [] :: [TyCon] + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) evBinds clsInsts tyCons +#else Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) +#endif where dflags = hsc_dflags hscEnv @@ -651,7 +673,7 @@ setupFinderCache mss session = do -- Make modules available for others that import them, -- by putting them in the finder cache. - let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss + let ims = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims -- set the target and module graph in the session graph = mkModuleGraph mss @@ -709,7 +731,7 @@ getModSummaryFromImports env fp modTime contents = do mod = fmap unLoc mb_mod `orElse` mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc @@ -778,7 +800,11 @@ parseHeader => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) +#if MIN_GHC_API_VERSION(9,0,1) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) +#else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +#endif parseHeader dflags filename contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseHeader (mkPState dflags contents loc) of @@ -827,10 +853,21 @@ parseFileContents env customPreprocessor filename ms = do throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module -> - let hpm_annotations = + let hpm_annotations :: ApiAnns + hpm_annotations = +#if MIN_GHC_API_VERSION(9,0,1) + -- Copied from GHC.Driver.Main + ApiAnns { + apiAnnItems = Map.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos pst, + apiAnnComments = Map.fromList (annotations_comments pst), + apiAnnRogueComments = comment_q pst + } +#else (Map.fromListWith (++) $ annotations pst, Map.fromList ((noSrcSpan,comment_q pst) :annotations_comments pst)) +#endif (warns, errs) = getMessages pst dflags in do @@ -853,7 +890,7 @@ parseFileContents env customPreprocessor filename ms = do throwE $ diagFromStrings "parser" DsError errs let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed + parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms (hpm_annotations) parsed -- To get the list of extra source files, we take the list -- that the parser gave us, diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index a09a379ba3..c2e0ee8896 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Development.IDE.Core.Preprocessor ( preprocessor @@ -79,7 +80,11 @@ preprocessor env filename mbContents = do return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogAction +#if __GLASGOW_HASKELL__ >= 900 + logAction cppLogs dflags _reason severity srcSpan msg = do +#else logAction cppLogs dflags _reason severity srcSpan _style msg = do +#endif let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg modifyIORef cppLogs (log :) @@ -107,7 +112,7 @@ diagsFromCPPLogs filename logs = -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc - go acc (CPPLog sev (RealSrcSpan span) msg : logs) = + go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index badb8628f9..c44152ad99 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -725,6 +725,8 @@ newSession extras@ShakeExtras{..} shakeDb acts = do logPriority logger (actionPriority d) msg notifyTestingLogMessage extras msg + -- The inferred type signature doesn't work in ghc >= 9.0.1 + workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do let acts' = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) res <- try @SomeException (restore $ shakeRunDatabase shakeDb acts') diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index 1470fae0c7..b3dc528a86 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -25,9 +25,8 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat import FileCleanup -import Module import Packages import Panic import SysTools @@ -188,7 +187,7 @@ addOptP opt = onSettings (onOptP (opt:)) -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal) -generatePackageVersionMacros :: [PackageConfig] -> String +generatePackageVersionMacros :: [Compat.PackageConfig] -> String generatePackageVersionMacros pkgs = concat -- Do not add any C-style comments. See #3389. [ generateMacros "" pkgname version @@ -221,7 +220,7 @@ getGhcVersionPathName dflags = do candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit]) found <- filterM doesFileExist candidates case found of diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index f7571a1593..c21ceb97d0 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} +{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! #include "ghc-api-version.h" -- | Attempt at hiding the GHC version differences we can. @@ -17,7 +18,6 @@ module Development.IDE.GHC.Compat( mkHieFile, mkHieFile', enrichHie, - RefMap, writeHieFile, readHieFile, supportsHieFiles, @@ -53,6 +53,65 @@ module Development.IDE.GHC.Compat( linkableTime, #endif +#if MIN_GHC_API_VERSION(9,0,1) + -- Reexports from GHC + UnitId, + moduleUnitId, + pkgState, + thisInstalledUnitId, + -- Reexports from DynFlags + thisPackage, + writeIfaceFile, +#else + RefMap, + Unit, +#endif + -- Linear + Scaled, + scaledThing, + + -- Reexports from Package + InstalledUnitId, + PackageConfig, + getPackageConfigMap, + getPackageIncludePath, + installedModule, + + packageName, + packageNameString, + packageVersion, + toInstalledUnitId, + lookupPackage, + lookupPackage', + explicitPackages, + exposedModules, + packageConfigId, + setThisInstalledUnitId, + initUnits, + lookupInstalledPackage, + oldLookupInstalledPackage, + unitDepends, + + haddockInterfaces, + + oldUnhelpfulSpan , + pattern IsBoot, + pattern NotBoot, + pattern OldRealSrcSpan, + + oldRenderWithStyle, + oldMkUserStyle, + oldMkErrStyle, + oldFormatErrDoc, + oldListVisibleModuleNames, + oldLookupModuleWithSuggestions, + + getRealSpan, + nodeInfo', + getNodeIds, + stringToUnit, + rtsUnit, + module GHC, module DynFlags, initializePlugins, @@ -70,7 +129,18 @@ import StringBuffer import qualified DynFlags import DynFlags hiding (ExposePackage) import Fingerprint (Fingerprint) +import qualified Outputable as Out +import qualified ErrUtils as Err import qualified Module +#if MIN_GHC_API_VERSION(9,0,1) +import qualified SrcLoc +import qualified Data.Set as S +import GHC.Iface.Load +import GHC.Core.TyCo.Rep (Scaled, scaledThing) +import GHC.Types.Unique.Set (emptyUniqSet) +#else +import Module (InstalledUnitId,toInstalledUnitId) +#endif import Packages import Data.IORef import HscTypes @@ -106,7 +176,7 @@ import Data.List (foldl', isSuffixOf) import DynamicLoading import Plugins (Plugin(parsedResultAction), withPlugins) -import Data.Map.Strict (Map) +import qualified Data.Map as M #if !MIN_GHC_API_VERSION(8,8,0) import System.FilePath ((-<.>)) @@ -153,7 +223,9 @@ upNameCache = updNameCache #endif -type RefMap a = Map Identifier [(Span, IdentifierDetails a)] +#if !MIN_GHC_API_VERSION(9,0,1) +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] +#endif mkHieFile' :: ModSummary -> [AvailInfo] @@ -226,8 +298,20 @@ nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_GHC_API_VERSION(9,0,0) +-- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) +-- type HasSrcSpan x = () :: Constraint + +class HasSrcSpan a where + getLoc :: a -> SrcSpan + +instance HasSrcSpan (GenLocated SrcSpan a) where + getLoc = GHC.getLoc + +-- getLoc :: GenLocated l a -> l +-- getLoc = GHC.getLoc +#elif MIN_GHC_API_VERSION(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan getLoc = GHC.getLoc @@ -257,8 +341,106 @@ getModuleHash = mi_mod_hash . mi_final_exts getModuleHash = mi_mod_hash #endif -getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName -getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) +-- type PackageName = Packages.PackageName +#if MIN_GHC_API_VERSION(9,0,0) +-- NOTE: Since both the new and old version uses UnitId with different meaning, +-- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous. +type UnitId = Module.Unit +type InstalledUnitId = Module.UnitId +type PackageConfig = Packages.UnitInfo +definiteUnitId = Module.RealUnit +defUnitId = Module.Definite +installedModule = Module.Module +-- pattern InstalledModule a b = Module.Module a b +packageName = Packages.unitPackageName +lookupPackage = Packages.lookupUnit . unitState +-- lookupPackage' = undefined +-- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u +lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? +-- lookupPackage' = fmap Packages.lookupUnit' . unitState +getPackageConfigMap = Packages.unitInfoMap . unitState +-- getPackageIncludePath = undefined +getPackageIncludePath = Packages.getUnitIncludePath +explicitPackages = Packages.explicitUnits +pkgState = GHC.unitState +packageNameString = Packages.unitPackageNameString +packageVersion = Packages.unitPackageVersion +-- toInstalledUnitId = id -- Module.toUnitId -- TODO: This is probably wrong +toInstalledUnitId = Module.toUnitId +exposedModules = Packages.unitExposedModules +packageConfigId = Packages.mkUnit +moduleUnitId = Module.moduleUnit +lookupInstalledPackage = Packages.lookupUnitId +oldLookupInstalledPackage = Packages.lookupUnitId . unitState +-- initUnits = Packages.initUnits +-- initPackages = initPackagesx +haddockInterfaces = unitHaddockInterfaces + +thisInstalledUnitId = GHC.homeUnitId +thisPackage = DynFlags.homeUnit +setThisInstalledUnitId uid df = df { homeUnitId = uid} + +oldUnhelpfulSpan = UnhelpfulSpan . SrcLoc.UnhelpfulOther +-- unhelpfulOther = unhelpfulOther . _ +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +pattern OldRealSrcSpan x <- RealSrcSpan x _ where + OldRealSrcSpan x = RealSrcSpan x Nothing +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + +oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState +oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState +-- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState + +oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc +oldMkUserStyle _ = Out.mkUserStyle +oldMkErrStyle _ = Out.mkErrStyle +oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc +oldFormatErrDoc = Err.formatErrDoc . undefined +-- oldFormatErrDoc = Err.formatErrDoc . undefined +writeIfaceFile = writeIface + +#else +type Unit = Module.UnitId +-- type PackageConfig = Packages.PackageConfig +definiteUnitId = Module.DefiniteUnitId +defUnitId = Module.DefUnitId +installedModule = Module.InstalledModule +oldLookupInstalledPackage = Packages.lookupInstalledPackage +-- packageName = Packages.packageName +-- lookupPackage = Packages.lookupPackage +-- getPackageConfigMap = Packages.getPackageConfigMap +setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid} + +oldUnhelpfulSpan = UnhelpfulSpan +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +pattern OldRealSrcSpan x = RealSrcSpan x +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + +pattern NotBoot, IsBoot :: IsBootInterface +pattern NotBoot = False +pattern IsBoot = True + +initUnits = fmap fst . Packages.initPackages + +unitDepends = depends + +oldListVisibleModuleNames = Packages.listVisibleModuleNames +oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions +-- oldLookupInPackageDB = Packages.lookupInPackageDB + +oldRenderWithStyle = Out.renderWithStyle +oldMkUserStyle = Out.mkUserStyle +oldMkErrStyle = Out.mkErrStyle +oldFormatErrDoc = Err.formatErrDoc + +-- Linear Haskell +type Scaled a = a +scaledThing :: Scaled a -> a +scaledThing = id +#endif + +getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName +getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i)) disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = @@ -309,3 +491,58 @@ isQualifiedImport ImportDecl{} = True isQualifiedImport ImportDecl{ideclQualified} = ideclQualified #endif isQualifiedImport _ = False + +getRealSpan :: SrcSpan -> Maybe RealSrcSpan +getRealSpan (OldRealSrcSpan x) = Just x +getRealSpan _ = Nothing + + + +#if __GLASGOW_HASKELL__ >= 900 +getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) +getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo + +ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd + +-- Copied from GHC and adjusted to accept TypeIndex instead of Type +-- nodeInfo' :: Ord a => HieAST a -> NodeInfo a +nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex +nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a +(NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: Ord a => [a] -> [a] -> [a] + mergeSorted la@(a:as) lb@(b:bs) = case compare a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + +stringToUnit = Module.stringToUnit +rtsUnit = Module.rtsUnit +#else + +getNodeIds = nodeIdentifiers . nodeInfo +-- import qualified FastString as FS + +-- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex +nodeInfo' :: Ord a => HieAST a -> NodeInfo a +nodeInfo' = nodeInfo +-- type Unit = UnitId +-- unitString :: Unit -> String +-- unitString = unitIdString +stringToUnit :: String -> Unit +stringToUnit = Module.stringToUnitId +-- moduleUnit :: Module -> Unit +-- moduleUnit = moduleUnitId +-- unhelpfulSpanFS :: FS.FastString -> FS.FastString +-- unhelpfulSpanFS = id +rtsUnit = Module.rtsUnitId +#endif + +#if MIN_GHC_API_VERSION(9,0,0) +#else +#endif diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index d8404b6123..f025957e8d 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -33,6 +33,7 @@ import Bag import Data.Maybe import Data.String (fromString) import qualified Data.Text as T +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location @@ -68,8 +69,8 @@ diagFromErrMsg diagSource dflags e = formatErrorWithQual :: DynFlags -> ErrMsg -> String formatErrorWithQual dflags e = Out.showSDoc dflags - $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e) - $ ErrUtils.formatErrDoc dflags + $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e) + $ GHC.oldFormatErrDoc dflags $ ErrUtils.errMsgDoc e diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] @@ -77,8 +78,9 @@ diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real +-- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = @@ -93,7 +95,8 @@ realSrcLocToPosition real = -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +-- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real) @@ -107,7 +110,7 @@ srcSpanToLocation src = do pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan +rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan @@ -149,7 +152,7 @@ diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan -noSpan = UnhelpfulSpan . FS.fsLit +noSpan = GHC.oldUnhelpfulSpan . FS.fsLit -- | creates a span with zero length in the filename of the argument passed @@ -160,8 +163,8 @@ zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case - RealSrcSpan r -> Just r - UnhelpfulSpan _ -> Nothing + GHC.OldRealSrcSpan r -> Just r + UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 089ba17af4..f6e1565ed1 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -20,7 +20,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import GHC () import GhcPlugins -import Retrie.ExactPrint (Annotated) +-- import Retrie.ExactPrint (Annotated) import qualified StringBuffer as SB @@ -36,14 +36,22 @@ instance Show Linkable where show = prettyPrint instance NFData Linkable where rnf = rwhnf instance Show PackageFlag where show = prettyPrint instance Show InteractiveImport where show = prettyPrint -instance Show ComponentId where show = prettyPrint instance Show PackageName where show = prettyPrint + +#if !MIN_GHC_API_VERSION(9,0,1) +instance Show ComponentId where show = prettyPrint instance Show SourcePackageId where show = prettyPrint -instance Show InstalledUnitId where +instance Show GhcPlugins.InstalledUnitId where show = installedUnitIdString -instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS +instance NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS + +instance Hashable GhcPlugins.InstalledUnitId where + hashWithSalt salt = hashWithSalt salt . installedUnitIdString +#else +instance Show InstalledUnitId where show = prettyPrint +#endif instance NFData SB.StringBuffer where rnf = rwhnf @@ -72,9 +80,6 @@ instance NFData FastString where instance NFData ParsedModule where rnf = rwhnf -instance Hashable InstalledUnitId where - hashWithSalt salt = hashWithSalt salt . installedUnitIdString - instance Show HieFile where show = show . hie_module @@ -146,8 +151,15 @@ instance NFData ModGuts where instance NFData (ImportDecl GhcPs) where rnf = rwhnf -instance Show (Annotated ParsedSource) where - show _ = "" +-- instance Show (Annotated ParsedSource) where +-- show _ = "" -instance NFData (Annotated ParsedSource) where +-- instance NFData (Annotated ParsedSource) where +-- rnf = rwhnf + +#if MIN_GHC_API_VERSION(9,0,1) +instance (NFData HsModule) where +#else +instance (NFData (HsModule a)) where +#endif rnf = rwhnf diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index f50cf1e386..3f699340bc 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +#include "ghc-api-version.h" -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -67,12 +68,11 @@ import Lexer import Module (moduleNameSlashes) import OccName (parenSymOcc) import Outputable (Depth (..), Outputable, SDoc, - mkUserStyle, neverQualify, ppr, - renderWithStyle, + neverQualify, ppr, showSDocUnsafe) -import PackageConfig (PackageConfig) -import Packages (getPackageConfigMap, - lookupPackage') +-- import PackageConfig (PackageConfig) +-- import Packages ( -- getPackageConfigMap, +-- lookupPackage') import RdrName (nameRdrName, rdrNameOcc) import SrcLoc (mkRealSrcLoc) import StringBuffer @@ -92,10 +92,10 @@ modifyDynFlags f = do modifySession $ \h -> h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } --- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment. -lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig -lookupPackageConfig unitId env = - lookupPackage' False pkgConfigMap unitId +-- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment. +lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig +lookupPackageConfig unit env = + GHC.lookupPackage' False pkgConfigMap unit where pkgConfigMap = -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap @@ -127,7 +127,7 @@ prettyPrint :: Outputable a => a -> String prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay) +unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) where dflags = unsafeGlobalDynFlags @@ -260,13 +260,17 @@ dupHandleTo filepath h other_side -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment! +#if MIN_GHC_API_VERSION(9,0,0) +dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev +#else dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev +#endif -> FilePath -> Maybe (MVar Handle__) -> Handle__ -> Maybe HandleFinalizer -> IO Handle -dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do +dupHandle_ new_dev filepath other_side Handle__{..} mb_finalizer = do -- XXX wrong! mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing mkHandle new_dev filepath haType True{-buffered-} mb_codec diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index f6838ce51c..7be5256dcb 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -28,9 +29,16 @@ import Language.LSP.Types (type (|?) (..)) withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- newVar [] +#if __GLASGOW_HASKELL__ >= 900 + let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () + newAction dynFlags wr _ loc msg = do + let prUnqual = alwaysQualify :: PrintUnqualified -- TODO: Do something proper here +#else let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () newAction dynFlags wr _ loc style msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg + let prUnqual = queryQual style +#endif + let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} warns <- readVar warnings diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 1f6e8ec0fc..992ec7c6b5 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -14,7 +14,7 @@ module Development.IDE.Import.FindImports , mkImportDirs ) where -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics @@ -88,7 +88,7 @@ locateModuleFile import_dirss exts doesExist isSource modName = do -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i -- | locate a module in either the file system or the package database. Where we go from *daml to @@ -96,7 +96,7 @@ mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName locateModule :: MonadIO m => DynFlags - -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories + -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name @@ -136,7 +136,7 @@ locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do Just file -> toModLocation file lookupInPackageDB dfs = - case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of + case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr dfs modName reason diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 046c0c9339..37651d27cb 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -38,7 +38,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (RealSrcSpan l) m) -> Just $ + (L (OldRealSrcSpan l) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile @@ -61,7 +61,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -71,7 +71,7 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -87,11 +87,11 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ nam , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (RealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs - , L (RealSrcSpan l') n <- names + | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs + , L (OldRealSrcSpan l') n <- names ] } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -101,10 +101,10 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name { _name = showRdrName n , _kind = SkConstructor , _selectionRange = realSrcSpanToRange l' - , _children = conArgRecordFields (getConArgs x) + , _children = conArgRecordFields (con_args x) } - | L (RealSrcSpan l ) x <- dd_cons - , L (RealSrcSpan l') n <- getConNames x + | L (OldRealSrcSpan l ) x <- dd_cons + , L (OldRealSrcSpan l') n <- getConNames' x ] } where @@ -115,48 +115,48 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name , _kind = SkField } | L _ cdf <- lcdfs - , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -190,7 +190,7 @@ documentSymbolForImportSummary importSymbols = } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule @@ -218,3 +218,9 @@ showRdrName = pprText pprText :: Outputable a => a -> Text pprText = pack . showSDocUnsafe . ppr + +-- the version of getConNames for ghc9 is restricted to only the renaming phase +getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] +getConNames' ConDeclH98 {con_name = name} = [name] +getConNames' ConDeclGADT {con_names = names} = names +getConNames' (XConDecl x) = noExtCon x diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 7059dbb7b6..8ecfa22549 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -256,7 +256,7 @@ suggestHideShadow ps@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_messag | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl @@ -440,10 +440,10 @@ suggestDeleteUnusedBinding findRelatedSpans indexedContent name - (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : @@ -466,7 +466,7 @@ suggestDeleteUnusedBinding let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused + Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match @@ -517,10 +517,10 @@ suggestDeleteUnusedBinding indexedContent name lsigs - (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then - let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches @@ -562,7 +562,7 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul -- we get the last export and the closing bracket and check for comma in that range needsComma :: T.Text -> Located [LIE GhcPs] -> Bool needsComma _ (L _ []) = False - needsComma source (L (RealSrcSpan l) exports) = + needsComma source (L (OldRealSrcSpan l) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of @@ -690,7 +690,7 @@ newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text - newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(RealSrcSpan sp) _) <- hsmodDecls + | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -934,7 +934,9 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@ , mode <- [ ToQualified parensed qual | ExistingImp imps <- [modTarget] - , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) + -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation + -- nubOrd can't be used since SrcSpan is intentionally no Ord + , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) $ NE.toList imps ] ++ [ToQualified parensed modName @@ -1002,10 +1004,10 @@ disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (UnhelpfulSpan "") rdr + L (oldUnhelpfulSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (UnhelpfulSpan "") rdr + prettyPrint $ L (oldUnhelpfulSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) @@ -1281,11 +1283,11 @@ newImportInsertRange :: ParsedSource -> Maybe (Range, Int) newImportInsertRange (L _ HsModule {..}) | Just (uncurry Position -> insertPos, col) <- case hsmodImports of [] -> case getLoc (head hsmodDecls) of - RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 + OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 in Just ((srcLocLine (realSrcSpanStart s) - 1, col), col) _ -> Nothing _ -> case getLoc (last hsmodImports) of - RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 + OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 in Just ((srcLocLine $ realSrcSpanEnd s,col), col) _ -> Nothing = Just (Range insertPos insertPos, col) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ad67a5f2f4..e6386a5cd9 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -40,7 +40,11 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS +#if MIN_GHC_API_VERSION(9,0,0) +import GHC.Tc.Module (tcRnImportDecls) +#else import TcRnDriver (tcRnImportDecls) +#endif descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index e7e02a48de..c089a25627 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -267,7 +267,8 @@ mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI let (args, ret) = splitFunTys t in if isForAllTy ret then getArgs ret - else Prelude.filter (not . isDictTy) args + -- TODO: Do we want to use multiplicity here? + else Prelude.filter (not . isDictTy) $ map scaledThing args | isPiTy t = getArgs $ snd (splitPiTys t) #if MIN_GHC_API_VERSION(8,10,0) | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t @@ -310,7 +311,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do packageState = hscEnv env curModName = moduleName curMod - importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -338,8 +339,12 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do (, mempty) <$> toCompItem par curMod curModName n Nothing getComplsForOne (GRE n par False prov) = flip foldMapM (map is_decl prov) $ \spec -> do - -- we don't want to extend import if it's already in scope - let originalImportDecl = if null $ lookupGRE_Name inScopeEnv n then Map.lookup (is_dloc spec) importMap else Nothing + let originalImportDecl = do + -- we don't want to extend import if it's already in scope + guard . null $ lookupGRE_Name inScopeEnv n + -- or if it doesn't have a real location + loc <- realSpan $ is_dloc spec + Map.lookup loc importMap compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl let unqual | is_qual spec = [] diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a638b75801..9968e38fb8 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} +#include "ghc-api-version.h" -- | An HLS plugin to provide code lenses for type signatures module Development.IDE.Plugin.TypeLenses ( @@ -80,7 +82,11 @@ import PatSyn (patSynName) import TcEnv (tcInitTidyEnv) import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (..)) +#if MIN_GHC_API_VERSION(9,0,1) +import GHC.Core.TyCo.Ppr (pprSigmaType) +#else import TcType (pprSigmaType) +#endif import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 0d33e88dff..61cd91381e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -61,7 +61,7 @@ import HieDb hiding (pointCommand) -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module -type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri +type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) @@ -90,7 +90,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> let posFile = fromMaybe pos $ fromCurrentPosition mapping pos - names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + names = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -155,7 +155,7 @@ documentHighlight -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights where - ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) + ns = concat $ pointCommand hf pos (rights . M.keys . getNodeIds) highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) @@ -210,7 +210,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ point range = realSrcSpanToRange $ nodeSpan ast wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" - info = nodeInfo ast + info = nodeInfoH kind ast names = M.assocs $ nodeIdentifiers info types = nodeType info @@ -252,7 +252,7 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) ts = concat $ pointCommand ast pos getts unfold = map (arr A.!) getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) - where ni = nodeInfo x + where ni = nodeInfo' x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] #if MIN_GHC_API_VERSION(8,8,0) @@ -262,7 +262,11 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) #endif HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) HForAllTy _ a -> getTypes [a] +#if MIN_GHC_API_VERSION(9,0,1) + HFunTy a b c -> getTypes [a,b,c] +#else HFunTy a b -> getTypes [a,b] +#endif HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] @@ -297,7 +301,7 @@ locationsAtPoint -> HieASTs a -> m [Location] locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = - let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports @@ -307,7 +311,7 @@ locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of - sp@(RealSrcSpan rsp) + sp@(OldRealSrcSpan rsp) -- Lookup in the db if we got a location in a boot file | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp sp -> do @@ -369,3 +373,8 @@ pointCommand hf pos k = sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos cha = _character pos + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index a23d616c5a..1fa04c1440 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -31,6 +31,8 @@ import NameEnv import Outputable hiding ((<>)) import Var +import Development.IDE.GHC.Compat (oldMkUserStyle, + oldRenderWithStyle) import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H @@ -50,8 +52,8 @@ showNameWithoutUniques :: Outputable a => a -> T.Text showNameWithoutUniques = T.pack . prettyprint where dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques - prettyprint x = renderWithStyle dyn (ppr x) style - style = mkUserStyle dyn neverQualify AllTheWay + prettyprint x = oldRenderWithStyle dyn (ppr x) style + style = oldMkUserStyle dyn neverQualify AllTheWay -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index bf7acd6116..4ecff71241 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -37,7 +37,7 @@ import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri) import Name import NameEnv -import Packages +-- import Packages import SrcLoc (RealLocated) import TcRnTypes @@ -143,9 +143,7 @@ getDocumentation sources targetName = fromMaybe [] $ do pure $ docHeaders $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v) - $ join - $ M.elems + $ fold docs where -- Get the name bound by a binding. We only concern ourselves with @@ -158,14 +156,15 @@ getDocumentation sources targetName = fromMaybe [] $ do sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after - ann = snd . pm_annotations +#if MIN_GHC_API_VERSION(9,0,0) + ann = apiAnnComments . pm_annotations +#else + ann = fmap filterReal . snd . pm_annotations + filterReal :: [Located a] -> [RealLocated a] + filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) +#endif annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann - realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] - realSpans = - mapMaybe (realSpan . getLoc) - . join - . M.elems + annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann -- | Shows this part of the documentation docHeaders :: [RealLocated AnnotationComment] @@ -216,7 +215,7 @@ lookupHtmlForModule mkDocPath df m = do -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] +lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath] lookupHtmls df ui = -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 6035479543..aa06276518 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -26,15 +26,10 @@ import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Types.Exports (ExportsMap, createExportsMap) import Development.IDE.Graph.Classes -import GhcPlugins (HscEnv (hsc_dflags), - InstalledPackageInfo (exposedModules), - Module (..), - PackageState (explicitPackages), - listVisibleModuleNames, - packageConfigId) +import GhcPlugins (HscEnv (hsc_dflags)) import LoadIface (loadInterface) import qualified Maybes -import Module (InstalledUnitId) +-- import Module (InstalledUnitId) import OpenTelemetry.Eventlog (withSpan) import System.Directory (canonicalizePath) import System.FilePath @@ -95,8 +90,8 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface "" - (Module (packageConfigId pkg) mn) - (ImportByUser False) + (mkModule (packageConfigId pkg) mn) + (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing Maybes.Succeeded mi -> Just mi @@ -109,7 +104,7 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames dflags) + (evaluate . force . Just $ oldListVisibleModuleNames dflags) return HscEnvEq{..} diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index f2f9bda8e3..8d40efe379 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -22,11 +22,12 @@ module Development.IDE.Types.Options import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat as GHC import Development.IDE.Types.Diagnostics import Development.IDE.Graph -import GHC hiding (parseModule, - typecheckModule) -import GhcPlugins as GHC hiding (fst3, (<>)) +-- import GHC hiding (parseModule, +-- typecheckModule) +-- import GhcPlugins as GHC hiding (fst3, (<>)) import Ide.Plugin.Config import qualified Language.LSP.Types.Capabilities as LSP From 66d66ad007fdd5db8cbf54c56535502b18b31766 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 1 Apr 2021 14:25:30 +0800 Subject: [PATCH 09/86] ghcide: Fix backwards compatability with ghc-8.8.4 --- ghcide/src/Development/IDE/LSP/Outline.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 37651d27cb..a64a150bc5 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -223,4 +223,8 @@ pprText = pack . showSDocUnsafe . ppr getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names +#if !MIN_GHC_API_VERSION(8,10,0) +getConNames' (XConDecl NoExt) = [] +#elif !MIN_GHC_API_VERSION(9,0,0) getConNames' (XConDecl x) = noExtCon x +#endif From 172e9e3286ee29968e415a207e0b5e7ed9e05928 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 1 Apr 2021 22:49:11 +0800 Subject: [PATCH 10/86] ghc9-ghcide: Fix some more issues that caused runtime errors --- .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/GHC/Compat.hs | 111 ++++++++++-------- ghcide/src/Development/IDE/GHC/Util.hs | 4 +- 3 files changed, 66 insertions(+), 51 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 932babab5b..3f38a21ca9 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -504,7 +504,7 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - initDynLinker env + -- initDynLinker env -- This causes ghc9 to crash pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index c21ceb97d0..b8eb33cc7b 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -1,10 +1,10 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} {-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! #include "ghc-api-version.h" @@ -70,6 +70,8 @@ module Development.IDE.GHC.Compat( Scaled, scaledThing, + lookupUnit', + preloadClosureUs, -- Reexports from Package InstalledUnitId, PackageConfig, @@ -82,7 +84,7 @@ module Development.IDE.GHC.Compat( packageVersion, toInstalledUnitId, lookupPackage, - lookupPackage', + -- lookupPackage', explicitPackages, exposedModules, packageConfigId, @@ -122,71 +124,67 @@ module Development.IDE.GHC.Compat( ,isQualifiedImport) where #if MIN_GHC_API_VERSION(8,10,0) -import LinkerTypes +import LinkerTypes #endif -import StringBuffer +import DynFlags hiding (ExposePackage) import qualified DynFlags -import DynFlags hiding (ExposePackage) -import Fingerprint (Fingerprint) -import qualified Outputable as Out -import qualified ErrUtils as Err +import qualified ErrUtils as Err +import Fingerprint (Fingerprint) import qualified Module +import qualified Outputable as Out +import StringBuffer #if MIN_GHC_API_VERSION(9,0,1) -import qualified SrcLoc -import qualified Data.Set as S +import qualified Data.Set as S +import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load -import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Types.Unique.Set (emptyUniqSet) +import qualified SrcLoc #else -import Module (InstalledUnitId,toInstalledUnitId) +import Module (InstalledUnitId, toInstalledUnitId) #endif -import Packages -import Data.IORef -import HscTypes -import NameCache -import qualified Data.ByteString as BS -import MkIface -import TcRnTypes -import Compat.HieAst (mkHieFile,enrichHie) -import Compat.HieBin -import Compat.HieTypes -import Compat.HieUtils +import Compat.HieAst (enrichHie, mkHieFile) +import Compat.HieBin +import Compat.HieTypes +import Compat.HieUtils +import qualified Data.ByteString as BS +import Data.IORef +import HscTypes +import MkIface +import NameCache +import Packages +import TcRnTypes #if MIN_GHC_API_VERSION(8,10,0) -import GHC.Hs.Extension +import GHC.Hs.Extension #else -import HsExtension +import HsExtension #endif +import Avail +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName) import qualified GHC import qualified TyCoRep -import GHC hiding ( - ModLocation, - HasSrcSpan, - lookupName, - getLoc - ) -import Avail #if MIN_GHC_API_VERSION(8,8,0) -import Data.List (foldl') +import Data.List (foldl') #else -import Data.List (foldl', isSuffixOf) +import Data.List (foldl', isSuffixOf) #endif -import DynamicLoading -import Plugins (Plugin(parsedResultAction), withPlugins) -import qualified Data.Map as M +import qualified Data.Map as M +import DynamicLoading +import Plugins (Plugin (parsedResultAction), withPlugins) #if !MIN_GHC_API_VERSION(8,8,0) -import System.FilePath ((-<.>)) +import System.FilePath ((-<.>)) #endif #if !MIN_GHC_API_VERSION(8,8,0) import qualified EnumSet -import System.IO -import Foreign.ForeignPtr +import Foreign.ForeignPtr +import System.IO hPutStringBuffer :: Handle -> StringBuffer -> IO () @@ -250,10 +248,11 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -pattern ModLocation a b c <- #if MIN_GHC_API_VERSION(8,8,0) +pattern ModLocation a b c <- GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else +pattern ModLocation a b c <- GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c #endif @@ -356,9 +355,11 @@ packageName = Packages.unitPackageName lookupPackage = Packages.lookupUnit . unitState -- lookupPackage' = undefined -- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u -lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? +-- lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? -- lookupPackage' = fmap Packages.lookupUnit' . unitState getPackageConfigMap = Packages.unitInfoMap . unitState +preloadClosureUs = Packages.preloadClosure . unitState +-- getPackageConfigMap = unitState -- getPackageIncludePath = undefined getPackageIncludePath = Packages.getUnitIncludePath explicitPackages = Packages.explicitUnits @@ -394,23 +395,35 @@ oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitStat oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc oldMkUserStyle _ = Out.mkUserStyle oldMkErrStyle _ = Out.mkErrStyle + +-- TODO: This is still a mess! oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc -oldFormatErrDoc = Err.formatErrDoc . undefined +oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext + where dummySDocContext = initSDocContext dflags Out.defaultUserStyle -- oldFormatErrDoc = Err.formatErrDoc . undefined writeIfaceFile = writeIface #else type Unit = Module.UnitId -- type PackageConfig = Packages.PackageConfig +definiteUnitId :: Module.DefUnitId -> UnitId definiteUnitId = Module.DefiniteUnitId +defUnitId :: InstalledUnitId -> Module.DefUnitId defUnitId = Module.DefUnitId +installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule installedModule = Module.InstalledModule +oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig oldLookupInstalledPackage = Packages.lookupInstalledPackage -- packageName = Packages.packageName -- lookupPackage = Packages.lookupPackage -- getPackageConfigMap = Packages.getPackageConfigMap +setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid} +lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig +lookupUnit' b pcm _ = Packages.lookupPackage' b pcm +preloadClosureUs = const () + oldUnhelpfulSpan = UnhelpfulSpan pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan pattern OldRealSrcSpan x = RealSrcSpan x @@ -486,15 +499,15 @@ pattern FunTy arg res <- TyCoRep.FunTy arg res isQualifiedImport :: ImportDecl a -> Bool #if MIN_GHC_API_VERSION(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False -isQualifiedImport ImportDecl{} = True +isQualifiedImport ImportDecl{} = True #else -isQualifiedImport ImportDecl{ideclQualified} = ideclQualified +isQualifiedImport ImportDecl{ideclQualified} = ideclQualified #endif -isQualifiedImport _ = False +isQualifiedImport _ = False getRealSpan :: SrcSpan -> Maybe RealSrcSpan getRealSpan (OldRealSrcSpan x) = Just x -getRealSpan _ = Nothing +getRealSpan _ = Nothing diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 3f699340bc..a0f0e5404a 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -95,12 +95,14 @@ modifyDynFlags f = do -- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment. lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig lookupPackageConfig unit env = - GHC.lookupPackage' False pkgConfigMap unit + -- GHC.lookupPackage' False pkgConfigMap unit + GHC.lookupUnit' False pkgConfigMap prClsre unit where pkgConfigMap = -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap -- from PackageState so we have to wrap it in DynFlags first. getPackageConfigMap $ hsc_dflags env + prClsre = preloadClosureUs $ hsc_dflags env -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. From 9f7331c11d00d11ac09b47707652ca8f5e0a34b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 1 Apr 2021 22:56:46 +0800 Subject: [PATCH 11/86] Restore initDynLinker for older versions of ghc It was probably important for something --- ghcide/session-loader/Development/IDE/Session.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3f38a21ca9..3233bb61c0 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -504,7 +504,10 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - -- initDynLinker env -- This causes ghc9 to crash +#if !MIN_GHC_API_VERSION(9,0,0) + -- This causes ghc9 to crash + initDynLinker env +#endif pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails From 9cb15234042a005da037dc3f8a82c429e9dcc501 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Fri, 2 Apr 2021 11:57:50 +0800 Subject: [PATCH 12/86] Fix ghc-8.6.5 compatability --- ghcide/src/Development/IDE/GHC/Compat.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index b8eb33cc7b..bde272d63d 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -26,6 +26,7 @@ module Development.IDE.GHC.Compat( #if !MIN_GHC_API_VERSION(8,8,0) ml_hie_file, addBootSuffixLocnOut, + getRealSrcSpan, #endif hPutStringBuffer, addIncludePathsQuote, @@ -108,7 +109,6 @@ module Development.IDE.GHC.Compat( oldListVisibleModuleNames, oldLookupModuleWithSuggestions, - getRealSpan, nodeInfo', getNodeIds, stringToUnit, @@ -177,6 +177,7 @@ import DynamicLoading import Plugins (Plugin (parsedResultAction), withPlugins) #if !MIN_GHC_API_VERSION(8,8,0) +import SrcLoc (RealLocated) import System.FilePath ((-<.>)) #endif @@ -463,6 +464,9 @@ disableWarningsAsErrors df = wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan = GHC.getLoc #endif applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource @@ -505,10 +509,6 @@ isQualifiedImport ImportDecl{ideclQualified} = ideclQualified #endif isQualifiedImport _ = False -getRealSpan :: SrcSpan -> Maybe RealSrcSpan -getRealSpan (OldRealSrcSpan x) = Just x -getRealSpan _ = Nothing - #if __GLASGOW_HASKELL__ >= 900 From ad42b0677f09b3064bb257193136ab485510ad05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 6 Apr 2021 14:34:05 +0800 Subject: [PATCH 13/86] Fix completion test failures for ghc9 With this example: f asdfgh = asd it would suggest to complete `asd` into `asd_arNC`, which seems to be a name it generated because of deferred-out-of-scope-variables --- ghcide/src/Development/IDE/Core/Compile.hs | 2 +- .../Development/IDE/Spans/LocalBindings.hs | 21 ++++++++++++------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 273ab35098..caa1ea765a 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -890,7 +890,7 @@ parseFileContents env customPreprocessor filename ms = do throwE $ diagFromStrings "parser" DsError errs let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms (hpm_annotations) parsed + parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed -- To get the list of extra source files, we take the list -- that the parser gave us, diff --git a/ghcide/src/Development/IDE/Spans/LocalBindings.hs b/ghcide/src/Development/IDE/Spans/LocalBindings.hs index 4856523148..cf23e37040 100644 --- a/ghcide/src/Development/IDE/Spans/LocalBindings.hs +++ b/ghcide/src/Development/IDE/Spans/LocalBindings.hs @@ -12,14 +12,18 @@ module Development.IDE.Spans.LocalBindings import Control.DeepSeq import Control.Monad import Data.Bifunctor -import Data.IntervalMap.FingerTree (IntervalMap, Interval (..)) -import qualified Data.IntervalMap.FingerTree as IM -import qualified Data.List as L -import qualified Data.Map as M -import qualified Data.Set as S -import Development.IDE.GHC.Compat (RefMap, identType, identInfo, getScopeFromContext, getBindSiteFromContext, Scope(..), Name, Type) +import Data.IntervalMap.FingerTree (Interval (..), IntervalMap) +import qualified Data.IntervalMap.FingerTree as IM +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, + getBindSiteFromContext, + getScopeFromContext, identInfo, + identType) import Development.IDE.GHC.Error import Development.IDE.Types.Location +import Name (isSystemName) import NameEnv import SrcLoc @@ -53,7 +57,7 @@ localBindings refmap = bimap mk mk $ unzip $ do Just scopes <- pure $ getScopeFromContext info scope <- scopes >>= \case LocalScope scope -> pure $ realSrcSpanToInterval scope - _ -> [] + _ -> [] pure ( scope , unitNameEnv name (name,ty) ) @@ -115,7 +119,8 @@ getDefiningBindings bs rss -- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b - = nameEnvElts + = filter (not . isSystemName . fst) + $ nameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getLocalBindings bs From 2f7b711c90fde61814c43549d15912bf9b4b7453 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 7 Apr 2021 16:07:43 +0800 Subject: [PATCH 14/86] Ghc-check now supports ghc-9.0.1 --- cabal.project | 14 +++++++------- ghcide/ghcide.cabal | 2 +- stack-8.6.4.yaml | 2 +- stack-8.6.5.yaml | 2 +- stack-8.8.2.yaml | 2 +- stack.yaml | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/cabal.project b/cabal.project index 62fcddf3f0..d73925c1ca 100644 --- a/cabal.project +++ b/cabal.project @@ -55,11 +55,11 @@ source-repository-package -- https://github.com/mokus0/th-extras/pull/8 -- https://github.com/mokus0/th-extras/issues/7 -source-repository-package - type: git - location: https://github.com/anka-213/ghc-check - tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d --- https://github.com/pepeiborra/ghc-check/pull/12 +-- source-repository-package +-- type: git +-- location: https://github.com/anka-213/ghc-check +-- tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d +-- -- https://github.com/pepeiborra/ghc-check/pull/12 source-repository-package type: git @@ -81,7 +81,7 @@ source-repository-package subdir: lsp-types subdir: lsp subdir: lsp-test --- https://github.com/haskell/lsp/pull/312/commits/3bf244fe0cf7ca9b895ae71fb526adba466ceaee +-- https://github.com/haskell/lsp/pull/312 source-repository-package type: git @@ -91,7 +91,7 @@ source-repository-package write-ghc-environment-files: never -index-state: 2021-03-29T21:23:14Z +index-state: 2021-04-07T07:31:23Z allow-newer: *:*, diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e9c52070cd..95ea863267 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -96,7 +96,7 @@ library ghc-boot-th, ghc-boot, ghc >= 8.6, - ghc-check >=0.5.0.1, + ghc-check >=0.5.0.4, ghc-paths, ghc-api-compat, cryptohash-sha1 >=0.11.100 && <0.12, diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 4e649c1245..24ac1ace8e 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -38,7 +38,7 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-check-0.5.0.1 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.4.20210206 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 8b475d2058..c45d0dc568 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -37,7 +37,7 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-check-0.5.0.1 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.4.20210206 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index cb755c4d0a..c6207bd53b 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -33,7 +33,7 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 - - ghc-check-0.5.0.1 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.4.20210206 diff --git a/stack.yaml b/stack.yaml index c88b7d1304..9e88c36369 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,7 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-check-0.5.0.1 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.3.4 - ghc-lib-8.10.4.20210206 From 8a257d03a0bdde069d83a8a233b1282eb78110bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 7 Apr 2021 16:12:59 +0800 Subject: [PATCH 15/86] Retrie now supports ghc-9.0.1 But it's not on hackage yet. --- cabal.project | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal.project b/cabal.project index d73925c1ca..b8fa32f96b 100644 --- a/cabal.project +++ b/cabal.project @@ -89,6 +89,12 @@ source-repository-package tag: 0.9.2.0 -- https://github.com/mpickering/apply-refact/issues/107 +source-repository-package + type: git + location: https://github.com/facebookincubator/retrie + tag: d2869440df5889d4af6f5b58c79b002d93ba9346 +-- https://github.com/facebookincubator/retrie/issues/25 + write-ghc-environment-files: never index-state: 2021-04-07T07:31:23Z From c7be52648a74ad92c90b6b2126e7e30b0916ec00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 7 Apr 2021 16:32:48 +0800 Subject: [PATCH 16/86] Restore retrie orphans --- ghcide/src/Development/IDE/GHC/Orphans.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index f6e1565ed1..aefa6f0b16 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -20,7 +20,7 @@ import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import GHC () import GhcPlugins --- import Retrie.ExactPrint (Annotated) +import Retrie.ExactPrint (Annotated) import qualified StringBuffer as SB @@ -151,11 +151,11 @@ instance NFData ModGuts where instance NFData (ImportDecl GhcPs) where rnf = rwhnf --- instance Show (Annotated ParsedSource) where --- show _ = "" +instance Show (Annotated ParsedSource) where + show _ = "" --- instance NFData (Annotated ParsedSource) where --- rnf = rwhnf +instance NFData (Annotated ParsedSource) where + rnf = rwhnf #if MIN_GHC_API_VERSION(9,0,1) instance (NFData HsModule) where From e0121f76631492feb04040cc249c9c36d8783358 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 7 Apr 2021 17:19:46 +0800 Subject: [PATCH 17/86] tests: Ghc9 shows [Char] as String by default This seems like an improvement, so just update the test-suite --- ghcide/test/exe/Main.hs | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index e1640ae740..8364637ec9 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -2209,14 +2209,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t [ (DsWarning, (6, 8), "Defaulting the following constraint") , (DsWarning, (6, 16), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f = seq (\"debug\" :: [Char]) traceShow \"debug\"" + , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" ]) , testSession "add default type to satisfy two contraints" $ testFor @@ -2229,14 +2229,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f a = traceShow \"debug\" a" ]) [ (DsWarning, (6, 6), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f a = traceShow (\"debug\" :: [Char]) a" + , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" ]) , testSession "add default type to satisfy two contraints with duplicate literals" $ testFor @@ -2249,14 +2249,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ]) [ (DsWarning, (6, 54), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" ]) ] where @@ -3374,7 +3374,7 @@ addSigLensesTests = , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") @@ -4313,10 +4313,11 @@ highlightTests = testGroup "highlight" highlights <- getHighlights doc (Position 4 15) liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before + [ #if MIN_GHC_API_VERSION(8,10,0) - [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) + DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else - [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) + DocumentHighlight (R 4 4 4 11) (Just HkWrite) #endif , DocumentHighlight (R 4 14 4 20) (Just HkRead) ] @@ -5671,3 +5672,11 @@ assertJust :: MonadIO m => String -> Maybe a -> m a assertJust s = \case Nothing -> liftIO $ assertFailure s Just x -> pure x + +-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String +listOfChar :: T.Text +#if MIN_GHC_API_VERSION(9,0,1) +listOfChar = "String" +#else +listOfChar = "[Char]" +#endif From 4874ba4dadfd2fe5760f2f39416032b0ee84042c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 7 Apr 2021 17:25:01 +0800 Subject: [PATCH 18/86] tests: Ghc9 shows TH-errors after the dollar sign Instead of including it like older versions did $(foo) ~~~~ some TH error/warning --- ghcide/test/exe/Main.hs | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8364637ec9..cb5c2e7a95 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3812,7 +3812,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] @@ -3824,7 +3824,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) ] closeDoc adoc @@ -3847,7 +3847,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] @@ -3856,7 +3856,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] closeDoc adoc closeDoc bdoc @@ -4863,7 +4863,7 @@ ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] closeDoc cdoc ifaceErrorTest :: TestTree @@ -5680,3 +5680,11 @@ listOfChar = "String" #else listOfChar = "[Char]" #endif + +-- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did +thDollarIdx :: Int +#if MIN_GHC_API_VERSION(9,0,1) +thDollarIdx = 1 +#else +thDollarIdx = 0 +#endif From de2f62e590fe599c52dc4efd988999f998ab3d07 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 8 Apr 2021 12:54:31 +0800 Subject: [PATCH 19/86] Fix two more test failures - GHC9 uses a more lenient haddock parser - TH2.17 has polymorphic Q monad with a type class --- ghcide/test/exe/Main.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index cb5c2e7a95..64cb6fb598 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -535,12 +535,17 @@ diagnosticTests = testGroup "diagnostics" , "foo = 1 {-|-}" ] _ <- createDoc "Foo.hs" "haskell" fooContent +#if MIN_GHC_API_VERSION(9,0,1) + -- Haddock parse errors are ignored on ghc-9.0.1 + pure () +#else expectDiagnostics [ ( "Foo.hs" , [(DsWarning, (2, 8), "Haddock parse error on input") ] ) ] +#endif , testSessionWait "strip file path" $ do let name = "Testing" @@ -3770,6 +3775,8 @@ thTests = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" , "module A (a) where" + , "import Language.Haskell.TH (ExpQ)" + , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic , "a = [| glorifiedID |]" , "glorifiedID :: a -> a" , "glorifiedID = id" ] From 617d555a5cc3dcd02cdbeaec2cf2981df990a922 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 8 Apr 2021 13:39:35 +0800 Subject: [PATCH 20/86] ghc9: Fix "Remove redundant imports" code action In ghc9, only the specific unused function is highlighted, instead of the whole line. --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 8ecfa22549..8f2455c6b5 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -304,7 +304,7 @@ suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [( suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports + , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports , Just c <- contents , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) From c34d1ec8a244fb428e7a2792b14cd9dca4949a29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 8 Apr 2021 14:49:02 +0800 Subject: [PATCH 21/86] ghcide-tests: Show errors where they are caused instead of deep inside some generic helper function --- ghcide/test/exe/Main.hs | 2 +- ghcide/test/src/Development/IDE/Test.hs | 14 +++++++------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 64cb6fb598..9bbf43bdbb 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -5294,7 +5294,7 @@ testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix testSession' :: String -> (FilePath -> Session ()) -> TestTree testSession' name = testCase name . run' -testSessionWait :: String -> Session () -> TestTree +testSessionWait :: HasCallStack => String -> Session () -> TestTree testSessionWait name = testSession name . -- Check that any diagnostics produced were already consumed by the test case. -- diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 420fb6736c..90e9b7ba31 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -47,7 +47,7 @@ type Cursor = (Int, Int) cursorPosition :: Cursor -> Position cursorPosition (line, col) = Position line col -requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion +requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do unless (any match actuals) $ assertFailure $ @@ -69,7 +69,7 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period -expectNoMoreDiagnostics :: Seconds -> Session () +expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri @@ -109,7 +109,7 @@ flushMessages = do -- -- Rather than trying to assert the absence of diagnostics, introduce an -- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) @@ -117,7 +117,7 @@ expectDiagnostics unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) -expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic @@ -125,7 +125,7 @@ expectDiagnosticsWithTags expected = do expectDiagnosticsWithTags' next expected' expectDiagnosticsWithTags' :: - MonadIO m => + (HasCallStack, MonadIO m) => m (Uri, List Diagnostic) -> Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> m () @@ -165,12 +165,12 @@ expectDiagnosticsWithTags' next expected = go expected <> show actual go $ Map.delete canonUri m -expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () expectCurrentDiagnostics doc expected = do diags <- getCurrentDiagnostics doc checkDiagnosticsForDoc doc expected diags -checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] nuri = toNormalizedUri _uri From 843b7fe3c977660908c555706e3a87cfd908c288 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Thu, 8 Apr 2021 15:59:17 +0800 Subject: [PATCH 22/86] Only use nub on SrcSpan for ghc>=9 --- ghcide/src/Development/IDE/Plugin/CodeAction.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 8f2455c6b5..312150fb72 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -934,9 +934,14 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@ , mode <- [ ToQualified parensed qual | ExistingImp imps <- [modTarget] +#if MIN_GHC_API_VERSION(9,0,0) + {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation -- nubOrd can't be used since SrcSpan is intentionally no Ord , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) +#else + , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) +#endif $ NE.toList imps ] ++ [ToQualified parensed modName From b7abb3e30a8069890235a4001bbf531c606c2453 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 14:59:18 +0800 Subject: [PATCH 23/86] Remove more CPP pragmas --- ghcide/src/Development/IDE/Core/Preprocessor.hs | 9 ++------- ghcide/src/Development/IDE/GHC/Compat.hs | 15 +++++++++++++++ ghcide/src/Development/IDE/GHC/Warnings.hs | 16 +++++----------- 3 files changed, 22 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index c2e0ee8896..544a88e7d7 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -1,6 +1,5 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} module Development.IDE.Core.Preprocessor ( preprocessor @@ -59,7 +58,7 @@ preprocessor env filename mbContents = do else do cppLogs <- liftIO $ newIORef [] contents <- ExceptT - $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename + $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: GhcException) -> do @@ -79,12 +78,8 @@ preprocessor env filename mbContents = do (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents return (contents, opts, dflags) where - logAction :: IORef [CPPLog] -> LogAction -#if __GLASGOW_HASKELL__ >= 900 - logAction cppLogs dflags _reason severity srcSpan msg = do -#else + logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do -#endif let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg modifyIORef cppLogs (log :) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index bde272d63d..9fc53a044e 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -114,6 +114,9 @@ module Development.IDE.GHC.Compat( stringToUnit, rtsUnit, + LogActionCompat, + logActionCompat, + module GHC, module DynFlags, initializePlugins, @@ -404,7 +407,19 @@ oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext -- oldFormatErrDoc = Err.formatErrDoc . undefined writeIfaceFile = writeIface +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () + +-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify + #else + +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () + +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style) + type Unit = Module.UnitId -- type PackageConfig = Packages.PackageConfig definiteUnitId :: Module.DefUnitId -> UnitId diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 7be5256dcb..df7ef0fb39 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -1,6 +1,5 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} {-# LANGUAGE ExplicitNamespaces #-} module Development.IDE.GHC.Warnings(withWarnings) where @@ -12,6 +11,8 @@ import GhcPlugins as GHC hiding (Var, (<>)) import Control.Concurrent.Strict import qualified Data.Text as T +import Development.IDE.GHC.Compat (LogActionCompat, + logActionCompat) import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..)) @@ -29,18 +30,11 @@ import Language.LSP.Types (type (|?) (..)) withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- newVar [] -#if __GLASGOW_HASKELL__ >= 900 - let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () - newAction dynFlags wr _ loc msg = do - let prUnqual = alwaysQualify :: PrintUnqualified -- TODO: Do something proper here -#else - let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () - newAction dynFlags wr _ loc style msg = do - let prUnqual = queryQual style -#endif + let newAction :: LogActionCompat + newAction dynFlags wr _ loc prUnqual msg = do let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) - res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} + res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}} warns <- readVar warnings return (reverse $ concat warns, res) From 98bd5ab68e7d237d30079e582d07906eecbb4c77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 15:05:39 +0800 Subject: [PATCH 24/86] Remove a bit more CPP This could almost be handled by ghc-api-compat, but if it was imported from TyCoPpr, it doesn't work with ghc < 8.10 --- ghcide/src/Development/IDE/GHC/Compat.hs | 4 ++++ ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 7 ------- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 9fc53a044e..032c009ade 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -117,6 +117,8 @@ module Development.IDE.GHC.Compat( LogActionCompat, logActionCompat, + pprSigmaType, + module GHC, module DynFlags, initializePlugins, @@ -139,12 +141,14 @@ import qualified Outputable as Out import StringBuffer #if MIN_GHC_API_VERSION(9,0,1) import qualified Data.Set as S +import GHC.Core.TyCo.Ppr (pprSigmaType) import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load import GHC.Types.Unique.Set (emptyUniqSet) import qualified SrcLoc #else import Module (InstalledUnitId, toInstalledUnitId) +import TcType (pprSigmaType) #endif import Compat.HieAst (enrichHie, mkHieFile) import Compat.HieBin diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 9968e38fb8..6d7ebe7fd8 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} -#include "ghc-api-version.h" -- | An HLS plugin to provide code lenses for type signatures module Development.IDE.Plugin.TypeLenses ( @@ -82,11 +80,6 @@ import PatSyn (patSynName) import TcEnv (tcInitTidyEnv) import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (..)) -#if MIN_GHC_API_VERSION(9,0,1) -import GHC.Core.TyCo.Ppr (pprSigmaType) -#else -import TcType (pprSigmaType) -#endif import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text From 365a4ad17749f3162ad930096df2987e632749d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 16:31:00 +0800 Subject: [PATCH 25/86] Update stack files to support new versions --- stack-8.10.2.yaml | 9 ++++++--- stack-8.10.3.yaml | 7 ++++++- stack-8.10.4.yaml | 7 ++++++- stack-8.6.4.yaml | 8 +++++--- stack-8.6.5.yaml | 10 +++++++--- stack-8.8.2.yaml | 8 +++++--- stack-8.8.3.yaml | 9 ++++++--- stack-8.8.4.yaml | 9 ++++++--- stack.yaml | 9 ++++++--- 9 files changed, 53 insertions(+), 23 deletions(-) diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 7614ab2ec7..a9cc897f4c 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -24,14 +24,16 @@ ghc-options: "$everything": -haddock extra-deps: - - apply-refact-0.9.0.0 - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - Cabal-3.0.2.0 - clock-0.7.2 - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 - - ghc-exactprint-0.6.3.4 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - lsp-1.2.0.0 @@ -48,6 +50,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 3018a10486..6588b57bd0 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -24,12 +24,16 @@ ghc-options: "$everything": -haddock extra-deps: - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - Cabal-3.0.2.0 - clock-0.7.2 - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - heapsize-0.3.0 @@ -43,6 +47,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - lsp-1.2.0.0 diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 4979c786f1..957999321a 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -24,12 +24,16 @@ ghc-options: "$everything": -haddock extra-deps: - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - Cabal-3.0.2.0 - clock-0.7.2 - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - heapsize-0.3.0 - hie-bios-0.7.4 - implicit-hie-cradle-0.3.0.2 @@ -41,6 +45,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - lsp-1.2.0.0 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 24ac1ace8e..9f5b97cd98 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -26,10 +26,10 @@ ghc-options: extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 + - apply-refact-0.9.2.0 - ansi-terminal-0.10.3 - base-compat-0.10.5 - - brittany-0.13.1.0 + - brittany-0.13.1.1 - butcher-1.3.3.1 - Cabal-3.0.2.0 - cabal-plan-0.6.2.0 @@ -38,9 +38,10 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 + - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - - ghc-exactprint-0.6.3.4 + - ghc-exactprint-0.6.4@sha256:51651c9491eae7a82e7623eb131c2a42a4b4e25d53e6ca4812aadec2cf32c947,9746 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 @@ -82,6 +83,7 @@ extra-deps: - topograph-1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index c45d0dc568..3d41c20cdf 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -23,12 +23,14 @@ packages: ghc-options: "$everything": -haddock + + extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 + - apply-refact-0.9.2.0 - ansi-terminal-0.10.3 - base-compat-0.10.5 - - brittany-0.13.1.0 + - brittany-0.13.1.1 - butcher-1.3.3.1 - Cabal-3.0.2.0 - cabal-plan-0.6.2.0 @@ -37,9 +39,10 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 + - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - - ghc-exactprint-0.6.3.4 + - ghc-exactprint-0.6.4@sha256:51651c9491eae7a82e7623eb131c2a42a4b4e25d53e6ca4812aadec2cf32c947,9746 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 @@ -81,6 +84,7 @@ extra-deps: - topograph-1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index c6207bd53b..20222b477d 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -25,17 +25,18 @@ ghc-options: extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - butcher-1.3.3.2 - bytestring-trie-0.2.5.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - - ghc-exactprint-0.6.3.4 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 @@ -66,6 +67,7 @@ extra-deps: - these-1.1.1.1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index ecf355c261..5355b9316e 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -25,15 +25,17 @@ ghc-options: extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - bytestring-trie-0.2.5.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 - - ghc-exactprint-0.6.3.4 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-trace-events-0.1.2.1 @@ -59,6 +61,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 - uniplate-1.6.13 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index b7a50c4431..25e5f17c1a 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -25,15 +25,17 @@ ghc-options: extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 - - brittany-0.13.1.0 + - apply-refact-0.9.2.0 + - brittany-0.13.1.1 - bytestring-trie-0.2.5.0 - cabal-plan-0.6.2.0 - clock-0.7.2 - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 - - ghc-exactprint-0.6.3.4 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-trace-events-0.1.2.1 @@ -57,6 +59,7 @@ extra-deps: - shake-0.19.4 - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 diff --git a/stack.yaml b/stack.yaml index 9e88c36369..9ce1557dc8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,10 +27,10 @@ ghc-options: extra-deps: - aeson-1.5.2.0 - - apply-refact-0.9.0.0 + - apply-refact-0.9.2.0 - ansi-terminal-0.10.3 - base-compat-0.10.5 - - brittany-0.13.1.0 + - brittany-0.13.1.1 - butcher-1.3.3.1 - Cabal-3.0.2.0 - cabal-plan-0.6.2.0 @@ -39,9 +39,11 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 + - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - - ghc-exactprint-0.6.3.4 + - ghc-api-compat-8.6 + - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 - ghc-lib-parser-ex-8.10.0.17 @@ -83,6 +85,7 @@ extra-deps: - topograph-1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 From 11dee816ef822019ab2dc1e85ccc452cc09767f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 19:17:54 +0800 Subject: [PATCH 26/86] Use the version of retire on hackage The new version is now released --- cabal.project | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index b8fa32f96b..1ede6eddb1 100644 --- a/cabal.project +++ b/cabal.project @@ -89,15 +89,9 @@ source-repository-package tag: 0.9.2.0 -- https://github.com/mpickering/apply-refact/issues/107 -source-repository-package - type: git - location: https://github.com/facebookincubator/retrie - tag: d2869440df5889d4af6f5b58c79b002d93ba9346 --- https://github.com/facebookincubator/retrie/issues/25 - write-ghc-environment-files: never -index-state: 2021-04-07T07:31:23Z +index-state: 2021-04-12T10:01:30Z allow-newer: *:*, From ca1fada8d10b09160788cce5ac20aab9a26a8fe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 23:30:20 +0800 Subject: [PATCH 27/86] Don't use allow-newer: *:* --- cabal.project | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 1ede6eddb1..ad9642106e 100644 --- a/cabal.project +++ b/cabal.project @@ -89,21 +89,57 @@ source-repository-package tag: 0.9.2.0 -- https://github.com/mpickering/apply-refact/issues/107 +source-repository-package + type: git + location: https://github.com/diagrams/active + tag: ca23431a8dfa013992f9164ccc882a3277361f17 +-- https://github.com/diagrams/active/pull/36 + write-ghc-environment-files: never index-state: 2021-04-12T10:01:30Z +constraints: + -- Diagrams doesn't support optparse-applicative >= 0.16 yet + optparse-applicative < 0.16 + allow-newer: - *:*, active:base, + assoc:base, + cryptohash-md5:base, + cryptohash-sha1:base, + constraints-extras:template-haskell, data-tree-print:base, + deepseq:base, + dependent-sum:some, + dependent-sum:constraints, diagrams-contrib:base, + diagrams-contrib:lens, + diagrams-contrib:random, diagrams-core:base, + diagrams-core:lens, diagrams-lib:base, + diagrams-lib:lens, diagrams-postscript:base, + diagrams-postscript:lens, diagrams-svg:base, + diagrams-svg:lens, dual-tree:base, + -- Does this make any sense? + entropy:Cabal, force-layout:base, + force-layout:lens, + floskell:ghc-prim, + floskell:base, + hashable:base, + hslogger:base, monoid-extras:base, + newtype-generics:base, + parallel:base, + regex-base:base, + regex-tdfa:base, statestack:base, - svg-builder:base + svg-builder:base, + these:base, + time-compat:base + From 5e419b1def48d20597ee8165683a4cd463e3e853 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 12 Apr 2021 23:48:07 +0800 Subject: [PATCH 28/86] ghcide-tests: Enable test no longer broken in ghc9 --- ghcide/test/exe/Main.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9bbf43bdbb..10a9696dfc 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,8 +36,8 @@ import Development.IDE.Core.PositionMapping (PositionResult (..), positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) -import qualified Development.IDE.Main as IDE import Development.IDE.GHC.Util +import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common @@ -75,17 +75,25 @@ import System.IO.Extra hiding (withTempDir) import qualified System.IO.Extra import System.Info.Extra (isWindows) import System.Process.Extra (CreateProcess (cwd), - proc, - readCreateProcessWithExitCode, createPipe) + createPipe, proc, + readCreateProcessWithExitCode) import Test.QuickCheck -- import Test.QuickCheck.Instances () +import Control.Concurrent.Async import Control.Lens ((^.)) import Control.Monad.Extra (whenJust) +import Data.IORef +import Data.IORef.Extra (atomicModifyIORef_) +import Data.String (IsString (fromString)) import Data.Tuple.Extra import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId) +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types +import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as L import System.Time.Extra import Test.Tasty @@ -93,14 +101,6 @@ import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun import Test.Tasty.QuickCheck -import Data.IORef -import Ide.PluginUtils (pluginDescToIdePlugins) -import Control.Concurrent.Async -import Ide.Types -import Data.String (IsString(fromString)) -import qualified Language.LSP.Types as LSP -import Data.IORef.Extra (atomicModifyIORef_) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Text.Regex.TDFA ((=~)) waitForProgressBegin :: Session () @@ -3587,7 +3587,11 @@ findDefinitionAndHoverTests = let , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" +#if MIN_GHC_API_VERSION(9,0,0) + , test no yes docL41 constr "type constraint in hover info #1012" +#else , test no broken docL41 constr "type constraint in hover info #1012" +#endif , test broken broken outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" From 1d0ee669891c48c1b4d6d01ac830d45470002343 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 13 Apr 2021 03:17:29 +0800 Subject: [PATCH 29/86] Update hiedb version for ghcide --- ghcide/ghcide.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 95ea863267..bb3481f09e 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -13,7 +13,7 @@ description: A library for building Haskell IDE's on top of the GHC API. 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.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 +tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 9.0.1 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -59,7 +59,7 @@ library hie-compat ^>= 0.1.0.0, hls-plugin-api ^>= 1.1.0.0, lens, - hiedb == 0.3.0.1, + hiedb == 0.3.0.*, lsp-types == 1.2.*, lsp == 1.2.*, mtl, From aa71c813be927e473050b42b20b9c1e4a03c94e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 13 Apr 2021 19:12:46 +0800 Subject: [PATCH 30/86] Adjust for a minor change in test output for ghc9 --- ghcide/test/exe/Main.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 10a9696dfc..f84fa615bf 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4729,7 +4729,12 @@ dependentFileTest = testGroup "addDependentFile" _ <-createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics +#if MIN_GHC_API_VERSION(9,0,0) + -- String vs [Char] causes this change in error message + [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] +#else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] +#endif -- Now modify the dependent file liftIO $ writeFile (dir "dep-file.txt") "B" let change = TextDocumentContentChangeEvent @@ -4993,7 +4998,12 @@ sessionDepsArePickedUp = testSession' -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics +#if MIN_GHC_API_VERSION(9,0,0) + -- String vs [Char] causes this change in error message + [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] +#else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] +#endif -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 From 38430fe4f3594b755fbf306cd53bc1b9c8a52b56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 13 Apr 2021 19:15:16 +0800 Subject: [PATCH 31/86] Fix benchmark test for ghc9 Cabal-3.2 is not buildable on ghc9, but 3.4 is builable on older ghc. --- ghcide/bench/lib/Experiments.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 919804d1b6..955df3e5d5 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -204,7 +204,7 @@ configP = <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) - <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) + <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0])) <|> UsePackage <$> strOption (long "example-path") <*> some moduleOption From 9ed74dd702c9628738e52b4797d407338be31037 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 13 Apr 2021 19:50:05 +0800 Subject: [PATCH 32/86] Mark minor issues as broken for ghc9 Ghc9 highlights both the constructor and the other fields Maybe this should just be accepted and not seen as broken? --- ghcide/test/exe/Main.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f84fa615bf..71ae4c3555 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3551,7 +3551,13 @@ findDefinitionAndHoverTests = let in mkFindTests -- def hover look expect - [ test yes yes fffL4 fff "field in record definition" + [ +#if MIN_GHC_API_VERSION(9,0,0) + -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" +#else + test yes yes fffL4 fff "field in record definition" +#endif , test yes yes fffL8 fff "field in record construction #1102" , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 @@ -4318,7 +4324,11 @@ highlightTests = testGroup "highlight" , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] - , testSessionWait "record" $ do + , +#if MIN_GHC_API_VERSION(9,0,0) + expectFailBecause "Ghc9 highlights the constructor and not just this field" $ +#endif + testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) From 480e67a718ad52894600d8af0dfc951c007d3fc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 13 Apr 2021 22:05:46 +0800 Subject: [PATCH 33/86] haddock-comments-plugin: Ghc9 support --- haskell-language-server.cabal | 1 + plugins/hls-class-plugin/hls-class-plugin.cabal | 1 + .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/HaddockComments.hs | 17 ++++++++++++++++- 4 files changed, 19 insertions(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bbe15bd12a..8dc6dad596 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -327,6 +327,7 @@ executable haskell-language-server , cryptohash-sha1 , deepseq , ghc + , ghc-api-compat , ghc-boot-th , ghcide , hashable diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 265e2827b3..cb01f853dc 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -28,6 +28,7 @@ library , base >=4.12 && <5 , containers , ghc + , ghc-api-compat , ghc-exactprint , ghcide ^>=1.2.0.2 , hls-plugin-api ^>=1.1.0.0 diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 0d12befcbd..335d5a35ec 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -21,6 +21,7 @@ library , containers , deepseq , ghc + , ghc-api-compat , ghcide ^>=1.2.0.2 , hls-plugin-api ^>=1.1.0.0 , lsp diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 58ee2c914a..c8a8847ddd 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +#include "ghc-api-version.h" module Ide.Plugin.HaddockComments (descriptor) where @@ -90,7 +92,11 @@ genForSig = GenComments {..} isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] collectKeys = keyFromTyVar 0 +#if MIN_GHC_API_VERSION(9,0,0) + comment = mkComment "-- ^ " badRealSrcSpan +#else comment = mkComment "-- ^ " noSrcSpan +#endif dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] genForRecord :: GenComments @@ -109,7 +115,11 @@ genForRecord = GenComments {..} collectKeys = keyFromCon +#if MIN_GHC_API_VERSION(9,0,0) + comment = mkComment "-- | " badRealSrcSpan +#else comment = mkComment "-- | " noSrcSpan +#endif ----------------------------------------------------------------------------- @@ -131,7 +141,7 @@ toAction title uri edit = CodeAction {..} toRange :: SrcSpan -> Maybe Range toRange src - | (RealSrcSpan s) <- src, + | (OldRealSrcSpan s) <- src, range' <- realSrcSpanToRange s = Just range' | otherwise = Nothing @@ -146,7 +156,12 @@ cleanPriorComments x = x {annPriorComments = []} ----------------------------------------------------------------------------- keyFromTyVar :: Int -> LHsType GhcPs -> [AnnKey] +#if MIN_GHC_API_VERSION(9,0,0) +-- GHC9 HsFunTy has 4 arguments, we could extract this +keyFromTyVar dep c@(L _ (HsFunTy _ _ x y)) +#else keyFromTyVar dep c@(L _ (HsFunTy _ x y)) +#endif | dep < 1 = mkAnnKey c : keyFromTyVar dep x ++ keyFromTyVar dep y | otherwise = [] keyFromTyVar dep (L _ t@HsForAllTy {}) = keyFromTyVar dep (hst_body t) From 410af4528836e4caf34960512e36d1e4e2b8b3bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 00:51:30 +0800 Subject: [PATCH 34/86] hls-eval-plugin: Partial ghc9 support --- ghcide/src/Development/IDE/GHC/Compat.hs | 52 ++++++++++++------- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../src/Ide/Plugin/Eval/GHC.hs | 5 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 2 +- .../src/Ide/Plugin/Eval/Util.hs | 3 +- 5 files changed, 37 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 032c009ade..1804063b13 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -63,6 +63,8 @@ module Development.IDE.GHC.Compat( -- Reexports from DynFlags thisPackage, writeIfaceFile, + + gcatch, #else RefMap, Unit, @@ -80,6 +82,7 @@ module Development.IDE.GHC.Compat( getPackageIncludePath, installedModule, + pattern DefiniteUnitId, packageName, packageNameString, packageVersion, @@ -132,29 +135,32 @@ module Development.IDE.GHC.Compat( import LinkerTypes #endif -import DynFlags hiding (ExposePackage) +import DynFlags hiding (ExposePackage) import qualified DynFlags -import qualified ErrUtils as Err -import Fingerprint (Fingerprint) +import qualified ErrUtils as Err +import Fingerprint (Fingerprint) import qualified Module -import qualified Outputable as Out +import qualified Outputable as Out import StringBuffer #if MIN_GHC_API_VERSION(9,0,1) -import qualified Data.Set as S -import GHC.Core.TyCo.Ppr (pprSigmaType) -import GHC.Core.TyCo.Rep (Scaled, scaledThing) +import Control.Exception.Safe as Safe (Exception, MonadCatch, catch) +import qualified Data.Set as S +import GHC.Core.TyCo.Ppr (pprSigmaType) +import GHC.Core.TyCo.Rep (Scaled, scaledThing) import GHC.Iface.Load -import GHC.Types.Unique.Set (emptyUniqSet) +import GHC.Types.Unique.Set (emptyUniqSet) import qualified SrcLoc #else -import Module (InstalledUnitId, toInstalledUnitId) -import TcType (pprSigmaType) +import Module (InstalledUnitId, + UnitId (DefiniteUnitId), + toInstalledUnitId) +import TcType (pprSigmaType) #endif -import Compat.HieAst (enrichHie, mkHieFile) +import Compat.HieAst (enrichHie, mkHieFile) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.IORef import HscTypes import MkIface @@ -169,23 +175,24 @@ import HsExtension #endif import Avail -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName) +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName) import qualified GHC import qualified TyCoRep #if MIN_GHC_API_VERSION(8,8,0) -import Data.List (foldl') +import Data.List (foldl') #else -import Data.List (foldl', isSuffixOf) +import Data.List (foldl', isSuffixOf) #endif -import qualified Data.Map as M +import qualified Data.Map as M import DynamicLoading -import Plugins (Plugin (parsedResultAction), withPlugins) +import Plugins (Plugin (parsedResultAction), + withPlugins) #if !MIN_GHC_API_VERSION(8,8,0) -import SrcLoc (RealLocated) -import System.FilePath ((-<.>)) +import SrcLoc (RealLocated) +import System.FilePath ((-<.>)) #endif #if !MIN_GHC_API_VERSION(8,8,0) @@ -355,6 +362,7 @@ getModuleHash = mi_mod_hash type UnitId = Module.Unit type InstalledUnitId = Module.UnitId type PackageConfig = Packages.UnitInfo +pattern DefiniteUnitId x = Module.RealUnit x definiteUnitId = Module.RealUnit defUnitId = Module.Definite installedModule = Module.Module @@ -417,6 +425,10 @@ type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnq logActionCompat :: LogActionCompat -> LogAction logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify +-- We are using Safe here, which is not equivalent, but probably what we want. +gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a +gcatch = Safe.catch + #else type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 1af0c5919f..b0b34d4175 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -59,6 +59,7 @@ library , extra , filepath , ghc + , ghc-api-compat , ghc-boot-th , ghc-paths , ghcide ^>=1.2.0.2 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs index 5a0349f0ba..ae3c26150c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -20,13 +20,10 @@ import Development.IDE.GHC.Compat import qualified EnumSet import GHC.LanguageExtensions.Type (Extension (..)) import GhcMonad (modifySession) -import GhcPlugins (DefUnitId (..), - InstalledUnitId (..), fsLit, - hsc_IC, pprHsString) +import GhcPlugins (fsLit, hsc_IC, pprHsString) import HscTypes (InteractiveContext (ic_dflags)) import Ide.Plugin.Eval.Util (asS, gStrictTry) import qualified Lexer -import Module (UnitId (DefiniteUnitId)) import Outputable (Outputable (ppr), SDoc, showSDocUnsafe, text, vcat, (<+>)) import qualified Parser diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index c081d07189..2489fb2ab6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -322,7 +322,7 @@ resultBlockP :: BlockCommentParser [String] resultBlockP = do BlockEnv {..} <- ask many $ - fmap fst . nonEmptyNormalLineP isLhs $ + fmap fst $ nonEmptyNormalLineP isLhs $ Block blockRange positionToSourcePos :: Position -> SourcePos diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index 82e3fcf9c3..1c0a6822d0 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -25,8 +25,9 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), ideLogger, logPriority) +import Development.IDE.GHC.Compat (gcatch) import Exception (ExceptionMonad, SomeException (..), - evaluate, gcatch) + evaluate) import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, From 78f1380d06b2202774bca0e819c51a1a2b815590 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 01:02:48 +0800 Subject: [PATCH 35/86] WIP: hls-eval-plugin: Partial ghc9 support --- .../src/Ide/Plugin/Eval/CodeLens.hs | 62 +++++++++++++++---- 1 file changed, 51 insertions(+), 11 deletions(-) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index ab0cac5865..ac69bf3caa 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,12 +7,14 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} +#include "ghc-api-version.h" {- | A plugin inspired by the REPLoid feature of , 's Examples and Properties and . @@ -74,7 +77,8 @@ import Development.IDE.GHC.Compat (AnnotationComment (AnnBlo GenLocated (L), GhcException, HscEnv, ParsedModule (..), - SrcSpan (RealSrcSpan, UnhelpfulSpan), + SrcSpan (UnhelpfulSpan), + moduleName, setInteractiveDynFlags, srcSpanFile) import qualified Development.IDE.GHC.Compat as SrcLoc @@ -89,7 +93,6 @@ import GHC (ExecOptions (execLineNumb HscTarget (HscInterpreted), LoadHowMuch (LoadAllTargets), ModSummary (ms_hspp_opts), - Module (moduleName), SuccessFlag (Failed, Succeeded), TcRnExprMode (..), execOptions, exprType, @@ -103,13 +106,9 @@ import GHC (ExecOptions (execLineNumb import GhcPlugins (DynFlags (..), defaultLogActionHPutStrDoc, gopt_set, gopt_unset, - hsc_dflags, interpWays, + hsc_dflags, parseDynamicFlagsCmdLine, - targetPlatform, - updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags, - xopt_set) + targetPlatform, xopt_set) import HscTypes (InteractiveImport (IIModule), ModSummary (ms_mod), Target (Target), @@ -141,6 +140,27 @@ import System.IO (hClose) import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) + +#if MIN_GHC_API_VERSION(9,0,0) +import GHC.Parser.Annotation (ApiAnns (apiAnnComments)) +#else +import GhcPlugins (interpWays, updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags) +#endif + +#if MIN_GHC_API_VERSION(9,0,0) +pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan +pattern RealSrcSpanAlready x = x +#else +apiAnnComments :: SrcLoc.ApiAnns -> Map.Map SrcSpan [SrcLoc.Located AnnotationComment] +apiAnnComments = snd + +pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan +pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x +#endif + + {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -159,7 +179,7 @@ codeLens st plId CodeLensParams{_textDocument} = runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap ( foldMap $ \case - L (RealSrcSpan real) bdy + L (RealSrcSpanAlready real) bdy | unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp , let ran0 = realSrcSpanToRange real @@ -176,7 +196,7 @@ codeLens st plId CodeLensParams{_textDocument} = _ -> mempty _ -> mempty ) - $ snd pm_annotations + $ apiAnnComments pm_annotations dbg "excluded comments" $ show $ DL.toList $ foldMap (foldMap $ \(L a b) -> @@ -185,7 +205,7 @@ codeLens st plId CodeLensParams{_textDocument} = AnnBlockComment{} -> mempty _ -> DL.singleton (a, b) ) - $ snd pm_annotations + $ apiAnnComments pm_annotations dbg "comments" $ show comments -- Extract tests from source code @@ -285,6 +305,20 @@ runEvalCmd st EvalParams{..} = df <- getSessionDynFlags setInteractiveDynFlags $ (foldl xopt_set idflags evalExtensions) +#if MIN_GHC_API_VERSION(9,0,0) + { unitState = + unitState + df + , unitDatabases = + unitDatabases + df + , packageFlags = + packageFlags + df + , useColor = Never + , canUseColor = False + } +#else { pkgState = pkgState df @@ -297,10 +331,16 @@ runEvalCmd st EvalParams{..} = , useColor = Never , canUseColor = False } +#endif -- set up a custom log action +#if MIN_GHC_API_VERSION(9,0,0) + setLogAction $ \_df _wr _sev _span _doc -> + defaultLogActionHPutStrDoc _df logHandle _doc +#else setLogAction $ \_df _wr _sev _span _style _doc -> defaultLogActionHPutStrDoc _df logHandle _doc _style +#endif -- Load the module with its current content (as the saved module might not be up to date) -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 From 10a0d7e4645bf1502bc2c66d0b1388b35e3366d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 01:33:17 +0800 Subject: [PATCH 36/86] hls-explicit-imports-plugin: Add ghc9 support Now ignores any imports with Unhelpful locations, since we can't make a map of SrcLoc --- .../src/Ide/Plugin/ExplicitImports.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index c9d067eb3f..9579f9bfc2 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -36,9 +36,14 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types +#if MIN_GHC_API_VERSION(9,0,0) +import GHC.Builtin.Names (pRELUDE) +#else import PrelNames (pRELUDE) +#endif import RnNames (findImportUsage, getMinimalImports) +import qualified SrcLoc import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (tcg_used_gres)) @@ -185,12 +190,13 @@ minimalImportsRule = define $ \MinimalImports nfp -> do (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList - [ (srcSpanStart l, T.pack (prettyPrint i)) - | L l i <- fromMaybe [] mbMinImports + [ (SrcLoc.realSrcSpanStart l, T.pack (prettyPrint i)) + | L (OldRealSrcSpan l) i <- fromMaybe [] mbMinImports ] res = - [ (i, Map.lookup (srcSpanStart (getLoc i)) importsMap) + [ (i, Map.lookup (SrcLoc.realSrcSpanStart l) importsMap) | i <- imports + , OldRealSrcSpan l <- [getLoc i] ] return ([], MinimalImportsResult res <$ mbMinImports) @@ -227,7 +233,7 @@ mkExplicitEdit posMapping (L src imp) explicit | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing | not (isQualifiedImport imp), - RealSrcSpan l <- src, + OldRealSrcSpan l <- src, L _ mn <- ideclName imp, -- (almost) no one wants to see an explicit import list for Prelude mn /= moduleName pRELUDE, From e880be02596259fcc54e40cf6cea599304353ba4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 02:23:04 +0800 Subject: [PATCH 37/86] hls-retrie-plugin: Add ghc9 support --- plugins/hls-retrie-plugin/hls-retrie-plugin.cabal | 1 + .../hls-retrie-plugin/src/Ide/Plugin/Retrie.hs | 15 ++++++++++----- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index f52a1731a3..8bb3251b51 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -23,6 +23,7 @@ library , directory , extra , ghc + , ghc-api-compat , ghcide ^>=1.2.0.2 , hashable , hls-plugin-api ^>=1.1.0.0 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index a39fd7ca54..e23eecdbcf 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -65,8 +66,11 @@ import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, TyClGroup (..), fun_id, mi_fixities, moduleNameString, - parseModule, rds_rules, - srcSpanFile) + parseModule, + pattern IsBoot, + pattern NotBoot, + pattern OldRealSrcSpan, + rds_rules, srcSpanFile) import GHC.Generics (Generic) import GhcPlugins (Outputable, SourceText (NoSourceText), @@ -466,8 +470,8 @@ asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = [] asTextEdits (Change reps _imports) = [ (filePathToUri spanLoc, edit) - | Replacement {..} <- nubOrdOn replLocation reps, - (RealSrcSpan rspan) <- [replLocation], + | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps, + (OldRealSrcSpan rspan) <- [replLocation], let spanLoc = unpackFS $ srcSpanFile rspan, let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement) ] @@ -536,8 +540,9 @@ data ImportSpec = AddImport deriving (Eq, Show, Generic, FromJSON, ToJSON) toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs -toImportDecl AddImport {..} = GHC.ImportDecl {..} +toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} where + ideclSource' = if ideclSource then IsBoot else NotBoot toMod = GHC.noLoc . GHC.mkModuleName ideclName = toMod ideclNameString ideclPkgQual = Nothing From de60f73c52b3e3ef3916de2c3b9be888998c8d1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 12:54:13 +0800 Subject: [PATCH 38/86] hls-hlint-plugin: Add ghc9 support --- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 12 ++++++---- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 24 +++++++++++++++---- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 1a39f9c2d6..95605a1100 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -12,6 +12,8 @@ maintainer: alan.zimm@gmail.com copyright: The Haskell IDE Team category: Development build-type: Simple +extra-source-files: + include/ghc-api-version.h flag pedantic description: Enable -Werror @@ -54,14 +56,16 @@ library , transformers , unordered-containers - if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.0.0)) - build-depends: ghc ^>=8.10 + if ((!flag(ghc-lib) && impl(ghc >=9.0.1)) && impl(ghc <9.1.0)) + build-depends: ghc ^>= 9.0.1 + -- if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.1.0)) + -- build-depends: ghc >=8.10 && < 9.1 else build-depends: , ghc - , ghc-lib ^>=8.10.4.20210206 - , ghc-lib-parser-ex ^>=8.10 + , ghc-lib >=8.10.4.20210206 && < 9.1 + , ghc-lib-parser-ex >=8.10 && < 9.1 cpp-options: -DHLINT_ON_GHC_LIB diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 7629ef5445..2c1ac68415 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -7,10 +7,17 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} +#ifdef HLINT_ON_GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + module Ide.Plugin.Hlint ( descriptor @@ -66,7 +73,8 @@ import System.IO (IOMode (Wri import System.IO.Temp #else import Development.IDE.GHC.Compat hiding - (DynFlags (..)) + (DynFlags (..), + OldRealSrcSpan) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) @@ -94,6 +102,14 @@ import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +#if MIN_GHC_API_VERSION(9,0,0) +pattern OldRealSrcSpan span <- RealSrcSpan span _ +#else +pattern OldRealSrcSpan span <- RealSrcSpan span +#endif +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = rules plId @@ -190,7 +206,7 @@ rules plugin = do -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc srcSpanToRange :: SrcSpan -> LSP.Range - srcSpanToRange (RealSrcSpan span) = Range { + srcSpanToRange (OldRealSrcSpan span) = Range { _start = LSP.Position { _line = srcSpanStartLine span - 1 , _character = srcSpanStartCol span - 1} @@ -230,7 +246,7 @@ getIdeas nfp = do (_, contents) <- getFileContents nfp let fp = fromNormalizedFilePath nfp let contents' = T.unpack <$> contents - Just <$> (liftIO $ parseModuleEx flags' fp contents') + Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do hlintExts <- getExtensions flags nfp @@ -463,7 +479,7 @@ applyHint ide nfp mhint = ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas - toRealSrcSpan (RealSrcSpan real) = real + toRealSrcSpan (OldRealSrcSpan real) = real toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x showParseError :: Hlint.ParseError -> String From 48f4ac532413cabcafa8b9f2806efc83dd3dd85a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 14 Apr 2021 18:30:53 +0800 Subject: [PATCH 39/86] Fix backwards compatability of hlint plugin --- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 34 ++++++++++++++----- 1 file changed, 26 insertions(+), 8 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 95605a1100..113c6b98d6 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -26,6 +26,12 @@ flag ghc-lib description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported +flag hlint33 + default: True + manual: False + description: + Hlint-3.3 doesn't support older ghc/ghc-lib versions, so we can use hlint-3.2 for backwards compat + library exposed-modules: Ide.Plugin.Hlint hs-source-dirs: src @@ -56,16 +62,28 @@ library , transformers , unordered-containers - if ((!flag(ghc-lib) && impl(ghc >=9.0.1)) && impl(ghc <9.1.0)) - build-depends: ghc ^>= 9.0.1 - -- if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.1.0)) - -- build-depends: ghc >=8.10 && < 9.1 + if (flag(hlint33)) + build-depends: hlint ^>=3.3 + else + build-depends: hlint ^>=3.2 + + if (!flag(ghc-lib) && (!flag(hlint33) && impl(ghc >=8.10.1) || flag(hlint33) && impl(ghc >=9.0.1)) && impl(ghc <9.1.0)) + if (flag(hlint33)) + build-depends: ghc ==9.0.* + else + build-depends: ghc >=8.10 && < 9.0 else - build-depends: - , ghc - , ghc-lib >=8.10.4.20210206 && < 9.1 - , ghc-lib-parser-ex >=8.10 && < 9.1 + if (flag(hlint33)) + build-depends: + , ghc + , ghc-lib == 9.0.* + , ghc-lib-parser-ex == 9.0.* + else + build-depends: + , ghc + , ghc-lib ^>= 8.10.4.20210206 + , ghc-lib-parser-ex ^>= 8.10 cpp-options: -DHLINT_ON_GHC_LIB From fc27789956771b6559438e8a5ba7b4c211a79e17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 09:07:35 +0800 Subject: [PATCH 40/86] Fix stack builds (Broken by previous hlint fixes) --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 ++ plugins/hls-eval-plugin/include/ghc-api-version.h | 10 ++++++++++ .../hls-haddock-comments-plugin.cabal | 2 ++ .../include/ghc-api-version.h | 10 ++++++++++ plugins/hls-hlint-plugin/hls-hlint-plugin.cabal | 2 -- stack-8.10.2.yaml | 4 ++++ stack-8.10.3.yaml | 4 ++++ stack-8.10.4.yaml | 10 ++++++++++ stack-8.6.4.yaml | 3 +++ stack-8.6.5.yaml | 3 +++ stack-8.8.2.yaml | 4 ++++ stack-8.8.3.yaml | 4 ++++ stack-8.8.4.yaml | 4 ++++ 13 files changed, 60 insertions(+), 2 deletions(-) create mode 100644 plugins/hls-eval-plugin/include/ghc-api-version.h create mode 100644 plugins/hls-haddock-comments-plugin/include/ghc-api-version.h diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index b0b34d4175..49f5440af1 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -24,6 +24,7 @@ extra-source-files: test/testdata/*.hs test/testdata/*.lhs test/testdata/*.yaml + include/ghc-api-version.h flag pedantic description: Enable -Werror @@ -88,6 +89,7 @@ library ghc-options: -Werror default-language: Haskell2010 + include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-eval-plugin/include/ghc-api-version.h b/plugins/hls-eval-plugin/include/ghc-api-version.h new file mode 100644 index 0000000000..11cabb3dc9 --- /dev/null +++ b/plugins/hls-eval-plugin/include/ghc-api-version.h @@ -0,0 +1,10 @@ +#ifndef GHC_API_VERSION_H +#define GHC_API_VERSION_H + +#ifdef GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +#endif diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index c46ea8b42f..21bb3094ea 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -16,6 +16,7 @@ bug-reports: https://github.com/haskell/haskell-language-server/issues extra-source-files: LICENSE test/testdata/*.hs + include/ghc-api-version.h library exposed-modules: Ide.Plugin.HaddockComments @@ -36,6 +37,7 @@ library , unordered-containers default-language: Haskell2010 + include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h b/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h new file mode 100644 index 0000000000..11cabb3dc9 --- /dev/null +++ b/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h @@ -0,0 +1,10 @@ +#ifndef GHC_API_VERSION_H +#define GHC_API_VERSION_H + +#ifdef GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +#endif diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 113c6b98d6..fcc87e4b85 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -12,8 +12,6 @@ maintainer: alan.zimm@gmail.com copyright: The Haskell IDE Team category: Development build-type: Simple -extra-source-files: - include/ghc-api-version.h flag pedantic description: Enable -Werror diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index a9cc897f4c..f6284881a8 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -73,6 +73,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 6588b57bd0..af327d6c54 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -73,6 +73,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [ icu libcxx zlib ] diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index 957999321a..f09a60be97 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -58,6 +58,12 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + # Enable these when supported by all formatters + # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 + # - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 + # - ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642 + # - hlint-3.3@sha256:4218ad6e03050f5d68aeba0e025f5f05e366c8fd49657f2a19df04ee31b2bb23,4154 + configure-options: ghcide: - --disable-library-for-ghci @@ -71,6 +77,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [ icu libcxx zlib ] diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 9f5b97cd98..a9f0929513 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -103,6 +103,9 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: false configure-options: ghcide: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 3d41c20cdf..081abdd19b 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -112,6 +112,9 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: false # allow-newer: true diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index 20222b477d..0ad74a5c52 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -96,6 +96,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false # allow-newer: true diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 5355b9316e..f5af19c5a9 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -90,6 +90,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false # allow-newer: true diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 25e5f17c1a..b1b8796e3e 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -87,6 +87,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false # allow-newer: true From 4bad4663530e9e19f0f0840487e56a9f1a4cdf66 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 09:58:07 +0800 Subject: [PATCH 41/86] Disable tests when their required plugins are disabled Not all plugins are supported on ghc9 yet, but we still want to run the tests for the supported parts --- haskell-language-server.cabal | 34 +++++++++ stack.yaml | 5 +- test/functional/Format.hs | 17 +++-- test/functional/ModuleName.hs | 3 +- test/functional/Progress.hs | 7 +- test/utils/Test/Hls/Flags.hs | 131 ++++++++++++++++++++++++++++++++++ 6 files changed, 185 insertions(+), 12 deletions(-) create mode 100644 test/utils/Test/Hls/Flags.hs diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8dc6dad596..9d42949684 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -430,6 +430,7 @@ test-suite func-test Symbol TypeDefinition Test.Hls.Command + Test.Hls.Flags default-extensions: OverloadedStrings ghc-options: @@ -438,6 +439,39 @@ test-suite func-test if flag(pedantic) ghc-options: -Werror -Wredundant-constraints + if flag(class) || flag(all-plugins) + cpp-options: -Dclass + if flag(haddockComments) || flag(all-plugins) + cpp-options: -DhaddockComments + if flag(eval) || flag(all-plugins) + cpp-options: -Deval + if flag(importLens) || flag(all-plugins) + cpp-options: -DimportLens + if flag(retrie) || flag(all-plugins) + cpp-options: -Dretrie + if flag(tactic) || flag(all-plugins) + cpp-options: -Dtactic + if flag(hlint) || flag(all-plugins) + cpp-options: -Dhlint + if flag(moduleName) || flag(all-plugins) + cpp-options: -DmoduleName + if flag(pragmas) || flag(all-plugins) + cpp-options: -Dpragmas + if flag(splice) || flag(all-plugins) + cpp-options: -Dsplice + +-- formatters + if flag(floskell) || flag(all-formatters) + cpp-options: -Dfloskell + if flag(fourmolu) || flag(all-formatters) + cpp-options: -Dfourmolu + if flag(ormolu) || flag(all-formatters) + cpp-options: -Dormolu + if flag(stylishHaskell) || flag(all-formatters) + cpp-options: -DstylishHaskell + if (flag(brittany) || flag(all-formatters)) + cpp-options: -Dbrittany + test-suite wrapper-test type: exitcode-stdio-1.0 build-tool-depends: diff --git a/stack.yaml b/stack.yaml index 9ce1557dc8..03f16cc074 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,7 +42,6 @@ extra-deps: - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - - ghc-api-compat-8.6 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 @@ -113,6 +112,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false # allow-newer: true diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 339e849e6a..7b4f5dbdfb 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -13,14 +13,17 @@ import Language.LSP.Types import qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command +import Test.Hls.Flags (requiresFloskellPlugin, + requiresFourmoluPlugin, + requiresOrmoluPlugin) tests :: TestTree tests = testGroup "format document" [ - goldenGitDiff "works" "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + requiresOrmoluPlugin $ goldenGitDiff "works" "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin $ goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 5 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc @@ -31,7 +34,7 @@ tests = testGroup "format document" [ ] rangeTests :: TestTree -rangeTests = testGroup "format range" [ +rangeTests = requiresOrmoluPlugin $ testGroup "format range" [ goldenGitDiff "works" "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 5 0) (Position 7 10)) @@ -55,7 +58,7 @@ providerTests = testGroup "formatting provider" [ formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedFloskell) - , testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" formattedOrmoluPostFloskell <- liftIO $ T.readFile "test/testdata/format/Format.ormolu_post_floskell.formatted.hs" @@ -73,7 +76,7 @@ providerTests = testGroup "formatting provider" [ sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedOrmoluPostFloskell) - , testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" @@ -90,7 +93,7 @@ providerTests = testGroup "formatting provider" [ ormoluTests :: TestTree -ormoluTests = testGroup "ormolu" +ormoluTests = requiresOrmoluPlugin $ testGroup "ormolu" [ goldenGitDiff "formats correctly" "test/testdata/format/Format.ormolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" @@ -104,7 +107,7 @@ ormoluTests = testGroup "ormolu" ] fourmoluTests :: TestTree -fourmoluTests = testGroup "fourmolu" +fourmoluTests = requiresFourmoluPlugin $ testGroup "fourmolu" [ goldenGitDiff "formats correctly" "test/testdata/format/Format.fourmolu.formatted.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" diff --git a/test/functional/ModuleName.hs b/test/functional/ModuleName.hs index 7c5b6130ba..a741776956 100644 --- a/test/functional/ModuleName.hs +++ b/test/functional/ModuleName.hs @@ -11,9 +11,10 @@ import qualified Data.Text.IO as T import System.FilePath ((<.>), ()) import Test.Hls import Test.Hls.Command +import Test.Hls.Flags (requiresModuleNamePlugin) tests :: TestTree -tests = testGroup +tests = requiresModuleNamePlugin $ testGroup "moduleName" [ testCase "Add module header to empty module" $ goldenTest "TEmptyModule.hs" , testCase "Fix wrong module name" $ goldenTest "TWrongModuleName.hs" diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index e35e83da41..365b7c2dfb 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -19,6 +19,7 @@ import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls import Test.Hls.Command +import Test.Hls.Flags tests :: TestTree tests = @@ -29,7 +30,7 @@ tests = let path = "hlint" "ApplyRefact2.hs" _ <- openDoc path "haskell" expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing", "Indexing"] - , testCase "eval plugin sends progress reports" $ + , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] @@ -37,14 +38,14 @@ tests = let cmd = evalLens ^?! L.command . _Just _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) expectProgressReports ["Evaluating"] - , testCase "ormolu plugin sends progress notifications" $ do + , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] - , testCase "fourmolu plugin sends progress notifications" $ do + , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" diff --git a/test/utils/Test/Hls/Flags.hs b/test/utils/Test/Hls/Flags.hs new file mode 100644 index 0000000000..84ff263f76 --- /dev/null +++ b/test/utils/Test/Hls/Flags.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +-- | Module for disabling tests if their plugins are disabled +module Test.Hls.Flags where + +import Test.Hls (TestTree, ignoreTestBecause) + +-- * Plugin dependent tests + +-- | Disable test unless the class flag is set +requiresClassPlugin :: TestTree -> TestTree +#if class +requiresClassPlugin = id +#else +requiresClassPlugin = ignoreTestBecause "Class plugin disabled" +#endif + +-- | Disable test unless the haddockComments flag is set +requiresHaddockCommentsPlugin :: TestTree -> TestTree +#if haddockComments +requiresHaddockCommentsPlugin = id +#else +requiresHaddockCommentsPlugin = ignoreTestBecause "HaddockComments plugin disabled" +#endif + +-- | Disable test unless the eval flag is set +requiresEvalPlugin :: TestTree -> TestTree +#if eval +requiresEvalPlugin = id +#else +requiresEvalPlugin = ignoreTestBecause "Eval plugin disabled" +#endif + +-- | Disable test unless the importLens flag is set +requiresImportLensPlugin :: TestTree -> TestTree +#if importLens +requiresImportLensPlugin = id +#else +requiresImportLensPlugin = ignoreTestBecause "ImportLens plugin disabled" +#endif + +-- | Disable test unless the retrie flag is set +requiresRetriePlugin :: TestTree -> TestTree +#if retrie +requiresRetriePlugin = id +#else +requiresRetriePlugin = ignoreTestBecause "Retrie plugin disabled" +#endif + +-- | Disable test unless the tactic flag is set +requiresTacticPlugin :: TestTree -> TestTree +#if tactic +requiresTacticPlugin = id +#else +requiresTacticPlugin = ignoreTestBecause "Tactic plugin disabled" +#endif + +-- | Disable test unless the hlint flag is set +requiresHlintPlugin :: TestTree -> TestTree +#if hlint +requiresHlintPlugin = id +#else +requiresHlintPlugin = ignoreTestBecause "Hlint plugin disabled" +#endif + +-- | Disable test unless the moduleName flag is set +requiresModuleNamePlugin :: TestTree -> TestTree +#if moduleName +requiresModuleNamePlugin = id +#else +requiresModuleNamePlugin = ignoreTestBecause "ModuleName plugin disabled" +#endif + +-- | Disable test unless the pragmas flag is set +requiresPragmasPlugin :: TestTree -> TestTree +#if pragmas +requiresPragmasPlugin = id +#else +requiresPragmasPlugin = ignoreTestBecause "Pragmas plugin disabled" +#endif + +-- | Disable test unless the splice flag is set +requiresSplicePlugin :: TestTree -> TestTree +#if splice +requiresSplicePlugin = id +#else +requiresSplicePlugin = ignoreTestBecause "Splice plugin disabled" +#endif + + +-- * Formatters +-- | Disable test unless the floskell flag is set +requiresFloskellPlugin :: TestTree -> TestTree +#if floskell +requiresFloskellPlugin = id +#else +requiresFloskellPlugin = ignoreTestBecause "Floskell plugin disabled" +#endif + +-- | Disable test unless the fourmolu flag is set +requiresFourmoluPlugin :: TestTree -> TestTree +#if fourmolu +requiresFourmoluPlugin = id +#else +requiresFourmoluPlugin = ignoreTestBecause "Fourmolu plugin disabled" +#endif + +-- | Disable test unless the ormolu flag is set +requiresOrmoluPlugin :: TestTree -> TestTree +#if ormolu +requiresOrmoluPlugin = id +#else +requiresOrmoluPlugin = ignoreTestBecause "Ormolu plugin disabled" +#endif + +-- | Disable test unless the stylishHaskell flag is set +requiresStylishHaskellPlugin :: TestTree -> TestTree +#if stylishHaskell +requiresStylishHaskellPlugin = id +#else +requiresStylishHaskellPlugin = ignoreTestBecause "StylishHaskell plugin disabled" +#endif + +-- | Disable test unless the brittany flag is set +requiresBrittanyPlugin :: TestTree -> TestTree +#if brittany +requiresBrittanyPlugin = id +#else +requiresBrittanyPlugin = ignoreTestBecause "Brittany plugin disabled" +#endif + From 6ca7365aa318836ba751d4cb170564b50d1f723f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 10:01:02 +0800 Subject: [PATCH 42/86] ghc9: Fix module name plugin --- plugins/default/src/Ide/Plugin/ModuleName.hs | 61 ++++++++++---------- 1 file changed, 32 insertions(+), 29 deletions(-) diff --git a/plugins/default/src/Ide/Plugin/ModuleName.hs b/plugins/default/src/Ide/Plugin/ModuleName.hs index 58ee66ccc8..f99e2062a1 100644 --- a/plugins/default/src/Ide/Plugin/ModuleName.hs +++ b/plugins/default/src/Ide/Plugin/ModuleName.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-unused-imports -Wno-unticked-promoted-constructors #-} @@ -15,38 +16,40 @@ module Ide.Plugin.ModuleName ( ) where import Control.Monad -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson (ToJSON (toJSON), Value (Null)) -import Data.Char (isLower) -import qualified Data.HashMap.Strict as Map -import Data.List (find, intercalate, isPrefixOf) -import Data.Maybe (maybeToList) -import Data.String (IsString) -import Data.Text (Text, pack) -import qualified Data.Text as T +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson (ToJSON (toJSON), Value (Null)) +import Data.Char (isLower) +import qualified Data.HashMap.Strict as Map +import Data.List (find, intercalate, isPrefixOf) +import Data.Maybe (maybeToList) +import Data.String (IsString) +import Data.Text (Text, pack) +import qualified Data.Text as T -- import Debug.Trace (trace) -import Development.IDE (GetParsedModule (GetParsedModule), - GhcSession (GhcSession), HscEnvEq, - IdeState, List (..), - NormalizedFilePath, - Position (Position), Range (Range), - evalGhcEnv, hscEnvWithImportPaths, - realSrcSpanToRange, runAction, - toNormalizedUri, uriToFilePath', use, - use_) -import GHC (DynFlags (importPaths), GenLocated (L), - HsModule (hsmodName), - ParsedModule (pm_parsed_source), - SrcSpan (RealSrcSpan), - getSessionDynFlags, unLoc) -import Ide.PluginUtils (getProcessID, mkLspCmdId) +import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), HscEnvEq, + IdeState, List (..), + NormalizedFilePath, + Position (Position), Range (Range), + evalGhcEnv, hscEnvWithImportPaths, + realSrcSpanToRange, runAction, + toNormalizedUri, uriToFilePath', + use, use_) +import Development.IDE.GHC.Compat (pattern OldRealSrcSpan) +import GHC (DynFlags (importPaths), + GenLocated (L), + HsModule (hsmodName), + ParsedModule (pm_parsed_source), + SrcSpan (RealSrcSpan), + getSessionDynFlags, unLoc) +import Ide.PluginUtils (getProcessID, mkLspCmdId) import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Language.LSP.VFS (virtualFileText) -import System.Directory (canonicalizePath) -import System.FilePath (dropExtension, splitDirectories, - takeFileName) +import Language.LSP.VFS (virtualFileText) +import System.Directory (canonicalizePath) +import System.FilePath (dropExtension, splitDirectories, + takeFileName) -- |Plugin descriptor descriptor :: PluginId -> PluginDescriptor IdeState @@ -146,7 +149,7 @@ pathModuleName state normFilePath filePath -- | The module name, as stated in the module codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, Text)) codeModuleName state nfp = - ((\(L (RealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>) + ((\(L (OldRealSrcSpan l) m) -> (realSrcSpanToRange l, T.pack . show $ m)) <$>) . ((hsmodName . unLoc . pm_parsed_source) =<<) <$> runAction "ModuleName.GetParsedModule" state (use GetParsedModule nfp) From 312378459318813d4145546d34b5e25fbf9562c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 20:08:56 +0800 Subject: [PATCH 43/86] Add a stack file and run tests for ghc9 in ci --- .circleci/config.yml | 6 ++ .github/workflows/test.yml | 22 ++++--- stack-9.0.1.yaml | 123 +++++++++++++++++++++++++++++++++++++ 3 files changed, 143 insertions(+), 8 deletions(-) create mode 100644 stack-9.0.1.yaml diff --git a/.circleci/config.yml b/.circleci/config.yml index b9702220fa..7257876959 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -103,6 +103,11 @@ jobs: - STACK_FILE: "stack-8.10.4.yaml" <<: *defaults + ghc-9.0.1: + environment: + - STACK_FILE: "stack-9.0.1.yaml" + <<: *defaults + ghc-default: environment: - STACK_FILE: "stack.yaml" @@ -121,4 +126,5 @@ workflows: - ghc-8.10.2 - ghc-8.10.3 - ghc-8.10.4 + - ghc-9.0.1 - ghc-default diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3b394f74dc..84450bbcdb 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -33,10 +33,13 @@ jobs: strategy: fail-fast: true matrix: - ghc: ["8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] + ghc: ["9.0.1", "8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] os: [ubuntu-latest, macOS-latest] include: # only test supported ghc major versions + - os: ubuntu-latest + ghc: '9.0.1' + test: true - os: ubuntu-latest ghc: '8.10.4' test: true @@ -70,7 +73,7 @@ jobs: uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} - cabal-version: "3.2" + cabal-version: "3.4" - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} run: ./fmt.sh @@ -106,6 +109,9 @@ jobs: - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} run: cabal update + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} + run: cabal configure --constraint "haskell-language-server -class -eval -tactic -moduleName -splice -fourmolu -ormolu -stylishHaskell -brittany" + # Need this to work around filepath length limits in Windows - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} name: Shorten binary names @@ -146,15 +152,15 @@ jobs: # instances to be spun up for the poor github actions runner to handle run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-brittany-plugin run: cabal test hls-brittany-plugin --test-options="-j1 --rerun-update" || cabal test hls-brittany-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-brittany-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-class-plugin run: cabal test hls-class-plugin --test-options="-j1 --rerun-update" || cabal test hls-class-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-eval-plugin run: cabal test hls-eval-plugin --test-options="-j1 --rerun-update" || cabal test hls-eval-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-eval-plugin --test-options="-j1 --rerun" @@ -162,15 +168,15 @@ jobs: name: Test hls-haddock-comments-plugin run: cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun-update" || cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-splice-plugin run: cabal test hls-splice-plugin --test-options="-j1 --rerun-update" || cabal test hls-splice-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-splice-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-stylish-haskell-plugin run: cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun-update" || cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-tactics-plugin test suite run: cabal test hls-tactics-plugin --test-options="-j1 --rerun-update" || cabal test hls-tactics-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-tactics-plugin --test-options="-j1 --rerun" diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml new file mode 100644 index 0000000000..0acba3cb4c --- /dev/null +++ b/stack-9.0.1.yaml @@ -0,0 +1,123 @@ +resolver: nightly-2021-05-02 +compiler: ghc-9.0.1 + +packages: + - . + - ./hie-compat + - ./ghcide/ + - ./hls-plugin-api + - ./hls-test-utils + # - ./shake-bench + # - ./plugins/hls-class-plugin + - ./plugins/hls-haddock-comments-plugin + # - ./plugins/hls-eval-plugin + - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-hlint-plugin + - ./plugins/hls-retrie-plugin + # - ./plugins/hls-splice-plugin + # - ./plugins/hls-tactics-plugin + # - ./plugins/hls-brittany-plugin + # - ./plugins/hls-stylish-haskell-plugin + +ghc-options: + "$everything": -haddock + +extra-deps: +- apply-refact-0.9.2.0 +- base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231 +- bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 +# Not newest (constraints-extras doesn't support 0.13 yet) +- constraints-0.12@sha256:71c7999d7fa01d8941f08d37d4c107c6b1bcbd0306e234157557b9b096b7f1be,2217 +- constraints-extras-0.3.1.0@sha256:12016ebb91ad5ed2c82bf7e48c6bd6947d164d33c9dca5ac3965de1bb6c780c0,1777 +- dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 +- dependent-sum-0.7.1.0@sha256:0e419237f5b86da3659772afff9cab355c0f8d5b3fdb15a5b30e673d8dc83941,2147 +- ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 +- ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 +- ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642 +- haddock-library-1.10.0@sha256:2a6c239da9225951a5d837e1ce373faeeae60d1345c78dd0a0b0f29df30c4fe9,4098 +- heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 +- hlint-3.3@sha256:4218ad6e03050f5d68aeba0e025f5f05e366c8fd49657f2a19df04ee31b2bb23,4154 +- implicit-hie-0.1.2.5@sha256:517a98ef72f92f0a1617495222774fed3a751a64b0c06fbfc7b858d7aa5de279,2998 +- implicit-hie-cradle-0.3.0.2@sha256:7ad0d10c475ad2b45a068aa0c1b150078ec579746df3b1754d91820354c90696,2594 +- lens-5.0.1 +- profunctors-5.6.2 +- refinery-0.3.0.0@sha256:5ec9588de8f9752b2a947a87ca6a5a0156150ed7b0197975730c007c4549e7fb,1675 +- retrie-1.0.0.0 +- some-1.0.2@sha256:3d460998df32ad7b93bf55657aeae988d97070155e71718b4bc75d0997ce9d62,2244 + +# Upstream patches for ghc-9.0.1 compatability +# Same as in cabal.project +- github: jwaldmann/blaze-textual + commit: d8ee6cf80e27f9619d621c936bb4bda4b99a183f +# https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f +# https://github.com/bos/blaze-textual/issues/13 + +- github: mithrandi/czipwith + commit: b6245884ae83e00dd2b5261762549b37390179f8 +# https://github.com/lspitzner/czipwith/pull/2 + +- github: jneira/hie-bios + commit: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 +# https://github.com/mpickering/hie-bios/pull/285 + +- github: hsyl20/ghc-api-compat + commit: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 + +- github: anka-213/th-extras + commit: 57a97b4df128eb7b360e8ab9c5759392de8d1659 +# https://github.com/mokus0/th-extras/pull/8 +# https://github.com/mokus0/th-extras/issues/7 + +- github: anka-213/dependent-sum + commit: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + subdirs: + - dependent-sum-template +# https://github.com/obsidiansystems/dependent-sum/pull/57 + +- github: anka-213/HieDb + commit: a3f7521f6c5af1b977040cce09c8f7354f8984eb +# https://github.com/wz1000/HieDb/pull/31 + +- github: anka-213/lsp + commit: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee + subdirs: + - lsp-types + - lsp + - lsp-test +# https://github.com/haskell/lsp/pull/312 + +- github: diagrams/active + commit: ca23431a8dfa013992f9164ccc882a3277361f17 +# https://github.com/diagrams/active/pull/36 + +configure-options: + ghcide: + - --disable-library-for-ghci + haskell-language-server: + - --disable-library-for-ghci + heapsize: + - --disable-library-for-ghci + +flags: + haskell-language-server: + pedantic: true + eval: false + class: false + splice: false + tactic: false # Dependencies fail + + floskell: false + ormolu: false + fourmolu: false + stylishHaskell: false + brittany: false + retrie: + BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: true + +nix: + packages: [ icu libcxx zlib ] + +concurrent-tests: false From a63acbc3a167de75273aeb8b6097b014114611cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 22:03:49 +0800 Subject: [PATCH 44/86] Add missing packages to ghc-9 stack --- stack-9.0.1.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 0acba3cb4c..19e3a200c0 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -4,6 +4,7 @@ compiler: ghc-9.0.1 packages: - . - ./hie-compat + - ./hls-graph - ./ghcide/ - ./hls-plugin-api - ./hls-test-utils @@ -12,6 +13,7 @@ packages: - ./plugins/hls-haddock-comments-plugin # - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin # - ./plugins/hls-splice-plugin From 64f67f2c8f87d0a45b18129900c2abf08baf2b9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 22:15:36 +0800 Subject: [PATCH 45/86] Resolve rebase issues Maybe it's better to create merge commits instead? --- .github/workflows/test.yml | 2 +- stack-9.0.1.yaml | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 84450bbcdb..9a3eba8ff2 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -110,7 +110,7 @@ jobs: run: cabal update - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} - run: cabal configure --constraint "haskell-language-server -class -eval -tactic -moduleName -splice -fourmolu -ormolu -stylishHaskell -brittany" + run: cabal configure --constraint "haskell-language-server -class -eval -refineImports -tactic -moduleName -splice -fourmolu -ormolu -stylishHaskell -brittany" # Need this to work around filepath length limits in Windows - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 19e3a200c0..cfe80dfc1e 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -13,7 +13,7 @@ packages: - ./plugins/hls-haddock-comments-plugin # - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin - - ./plugins/hls-refine-imports-plugin + # - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-retrie-plugin # - ./plugins/hls-splice-plugin @@ -106,6 +106,7 @@ flags: eval: false class: false splice: false + refineImports: false tactic: false # Dependencies fail floskell: false From 7931e2ffe5708cf94deabedc1dce02c9da2b7099 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 2 May 2021 22:25:04 +0800 Subject: [PATCH 46/86] Allow newer for more packages so cabal stops complaining These aren't really working, but since they are dependencies of packages in the `packages:` section the resolver won't allow us to build anything without this, even if those plugins are disabled. --- cabal.project | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/cabal.project b/cabal.project index ad9642106e..cf6e41946b 100644 --- a/cabal.project +++ b/cabal.project @@ -104,41 +104,53 @@ constraints: optparse-applicative < 0.16 allow-newer: - active:base, + -- Broken on ghc9, but let's pretend it's not so we can build the other things + brittany:base, + brittany:ghc, + brittany:ghc-boot-th, + butcher:base, + fourmolu:ghc-lib-parser, + ormolu:ghc-lib-parser, + stylish-haskell:ghc-lib-parser, + stylish-haskell:Cabal, + multistate:base, + ghc-source-gen:ghc, + + active:base, assoc:base, cryptohash-md5:base, cryptohash-sha1:base, constraints-extras:template-haskell, - data-tree-print:base, + data-tree-print:base, deepseq:base, dependent-sum:some, dependent-sum:constraints, - diagrams-contrib:base, + diagrams-contrib:base, diagrams-contrib:lens, diagrams-contrib:random, - diagrams-core:base, + diagrams-core:base, diagrams-core:lens, - diagrams-lib:base, + diagrams-lib:base, diagrams-lib:lens, - diagrams-postscript:base, + diagrams-postscript:base, diagrams-postscript:lens, - diagrams-svg:base, + diagrams-svg:base, diagrams-svg:lens, - dual-tree:base, + dual-tree:base, -- Does this make any sense? entropy:Cabal, - force-layout:base, + force-layout:base, force-layout:lens, floskell:ghc-prim, floskell:base, hashable:base, hslogger:base, - monoid-extras:base, + monoid-extras:base, newtype-generics:base, parallel:base, regex-base:base, regex-tdfa:base, - statestack:base, + statestack:base, svg-builder:base, these:base, time-compat:base From 7812a9bce2b586c30a23d4ce4063b47254851220 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 3 May 2021 09:33:29 +0800 Subject: [PATCH 47/86] Replace MIN_GHC_API_VERSION with MIN_VERSION_ghc --- .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/Compile.hs | 32 ++++++------ ghcide/src/Development/IDE/GHC/CPP.hs | 14 ++--- ghcide/src/Development/IDE/GHC/Compat.hs | 52 +++++++++---------- ghcide/src/Development/IDE/GHC/Orphans.hs | 6 +-- ghcide/src/Development/IDE/LSP/Outline.hs | 6 +-- .../src/Development/IDE/Plugin/CodeAction.hs | 2 +- .../src/Development/IDE/Plugin/Completions.hs | 2 +- .../IDE/Plugin/Completions/Logic.hs | 4 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 4 +- .../Development/IDE/Spans/Documentation.hs | 2 +- ghcide/test/exe/Main.hs | 26 +++++----- .../src/Ide/Plugin/Eval/CodeLens.hs | 8 +-- .../src/Ide/Plugin/ExplicitImports.hs | 2 +- .../src/Ide/Plugin/HaddockComments.hs | 6 +-- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 +-- .../src/Ide/Plugin/Retrie.hs | 4 +- 17 files changed, 89 insertions(+), 89 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 3233bb61c0..94f0098927 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -504,7 +504,7 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession -#if !MIN_GHC_API_VERSION(9,0,0) +#if !MIN_VERSION_ghc(9,0,0) -- This causes ghc9 to crash initDynLinker env #endif diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index caa1ea765a..bb110bbb90 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -57,7 +57,7 @@ import LoadIface (loadModuleInterface) import Lexer import qualified Parser -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import Control.DeepSeq (force, rnf) #else import Control.DeepSeq (rnf) @@ -81,7 +81,7 @@ import MkIface import StringBuffer as SB import TcIface (typecheckIface) import TcRnMonad hiding (newUnique) -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) import GHC.Builtin.Names import GHC.Iface.Recomp import GHC.Tc.Gen.Splice @@ -241,7 +241,7 @@ mkHiFileResultNoCompile session tcm = do tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) iface <- mkIfaceTc hsc_env_tmp sf details tcGblEnv #else (iface, _) <- mkIfaceTc hsc_env_tmp Nothing sf details tcGblEnv @@ -275,10 +275,10 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do (guts, details) <- tidyProgram session simplified_guts (diags, linkable) <- genLinkable session ms guts pure (linkable, details, diags) -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface Nothing -#elif MIN_GHC_API_VERSION(8,10,0) +#elif MIN_VERSION_ghc(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface #else @@ -340,18 +340,18 @@ generateObjectCode session summary guts = do (warnings, dot_o_fp) <- withWarnings "object" $ \_tweak -> do let summary' = _tweak summary -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) target = defaultObjectTarget $ hsc_dflags session #else target = defaultObjectTarget $ targetPlatform $ hsc_dflags session #endif session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts #else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts #endif -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) (ms_location summary') #else summary' @@ -374,7 +374,7 @@ generateByteCode hscEnv summary guts = do let summary' = _tweak summary session = hscEnv { hsc_dflags = ms_hspp_opts summary' } hscInteractive session guts -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) (ms_location summary') #else summary' @@ -433,7 +433,7 @@ unnecessaryDeprecationWarningFlags , Opt_WarnUnusedMatches , Opt_WarnUnusedTypePatterns , Opt_WarnUnusedForalls -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , Opt_WarnUnusedRecordWildcards #endif , Opt_WarnInaccessibleCode @@ -478,7 +478,7 @@ generateHieAsts hscEnv tcm = -- don't export an interface which allows for additional information to be added to hie files. let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) -- TODO: Use some proper values here! evBinds = emptyBag @EvBind :: Bag EvBind clsInsts = [] :: [ClsInst] @@ -760,7 +760,7 @@ getModSummaryFromImports env fp modTime contents = do msrModSummary = ModSummary { ms_mod = modl -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) , ms_hie_date = Nothing #endif , ms_hs_date = modTime @@ -800,7 +800,7 @@ parseHeader => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) #else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) @@ -808,7 +808,7 @@ parseHeader parseHeader dflags filename contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseHeader (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else @@ -846,7 +846,7 @@ parseFileContents env customPreprocessor filename ms = do dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms case unP Parser.parseModule (mkPState dflags contents loc) of -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else PFailed _ locErr msgErr -> @@ -855,7 +855,7 @@ parseFileContents env customPreprocessor filename ms = do POk pst rdr_module -> let hpm_annotations :: ApiAnns hpm_annotations = -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) -- Copied from GHC.Driver.Main ApiAnns { apiAnnItems = Map.fromListWith (++) $ annotations pst, diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index b3dc528a86..16f983ce68 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -30,12 +30,12 @@ import FileCleanup import Packages import Panic import SysTools -#if MIN_GHC_API_VERSION(8,8,2) +#if MIN_VERSION_ghc(8,8,2) import LlvmCodeGen (llvmVersionList) -#elif MIN_GHC_API_VERSION(8,8,0) +#elif MIN_VERSION_ghc(8,8,0) import LlvmCodeGen (LlvmVersion (..)) #endif -#if MIN_GHC_API_VERSION (8,10,0) +#if MIN_VERSION_ghc (8,10,0) import Fingerprint import ToolSettings #endif @@ -65,7 +65,7 @@ doCpp dflags raw input_fn output_fn = do let verbFlags = getVerbFlags dflags let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) | otherwise = SysTools.runCc Nothing #else | otherwise = SysTools.runCc @@ -149,11 +149,11 @@ getBackendDefs :: DynFlags -> IO [String] getBackendDefs dflags | hscTarget dflags == HscLlvm = do llvmVer <- figureLlvmVersion dflags return $ case llvmVer of -#if MIN_GHC_API_VERSION(8,8,2) +#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_GHC_API_VERSION(8,8,0) +#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 @@ -169,7 +169,7 @@ getBackendDefs _ = return [] addOptP :: String -> DynFlags -> DynFlags -#if MIN_GHC_API_VERSION (8,10,0) +#if MIN_VERSION_ghc (8,10,0) addOptP f = alterToolSettings $ \s -> s { toolSettings_opt_P = f : toolSettings_opt_P s , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index 1804063b13..9e8e023b6c 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -23,7 +23,7 @@ module Development.IDE.GHC.Compat( supportsHieFiles, setHieDir, dontWriteHieFiles, -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) ml_hie_file, addBootSuffixLocnOut, getRealSrcSpan, @@ -45,7 +45,7 @@ module Development.IDE.GHC.Compat( tcg_exports, pattern FunTy, -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) module GHC.Hs.Extension, module LinkerTypes, #else @@ -54,7 +54,7 @@ module Development.IDE.GHC.Compat( linkableTime, #endif -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) -- Reexports from GHC UnitId, moduleUnitId, @@ -131,7 +131,7 @@ module Development.IDE.GHC.Compat( dropForAll ,isQualifiedImport) where -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import LinkerTypes #endif @@ -142,7 +142,7 @@ import Fingerprint (Fingerprint) import qualified Module import qualified Outputable as Out import StringBuffer -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) import Control.Exception.Safe as Safe (Exception, MonadCatch, catch) import qualified Data.Set as S import GHC.Core.TyCo.Ppr (pprSigmaType) @@ -168,7 +168,7 @@ import NameCache import Packages import TcRnTypes -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import GHC.Hs.Extension #else import HsExtension @@ -179,7 +179,7 @@ import GHC hiding (HasSrcSpan, ModLocation, getLoc, lookupName) import qualified GHC import qualified TyCoRep -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) import Data.List (foldl') #else import Data.List (foldl', isSuffixOf) @@ -190,12 +190,12 @@ import DynamicLoading import Plugins (Plugin (parsedResultAction), withPlugins) -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) import SrcLoc (RealLocated) import System.FilePath ((-<.>)) #endif -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import Foreign.ForeignPtr @@ -209,7 +209,7 @@ hPutStringBuffer hdl (StringBuffer buf len cur) #endif -#if !MIN_GHC_API_VERSION(8,10,0) +#if !MIN_VERSION_ghc(8,10,0) noExtField :: NoExt noExtField = noExt #endif @@ -220,7 +220,7 @@ supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) ml_hie_file :: GHC.ModLocation -> FilePath ml_hie_file ml | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" @@ -228,7 +228,7 @@ ml_hie_file ml #endif upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if !MIN_GHC_API_VERSION(8,8,0) +#if !MIN_VERSION_ghc(8,8,0) upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn #else @@ -236,7 +236,7 @@ upNameCache = updNameCache #endif -#if !MIN_GHC_API_VERSION(9,0,1) +#if !MIN_VERSION_ghc(9,0,1) type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] #endif @@ -263,7 +263,7 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) pattern ModLocation a b c <- GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else @@ -273,7 +273,7 @@ pattern ModLocation a b c <- setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) d { hieDir = Just _f} #else d @@ -281,7 +281,7 @@ setHieDir _f d = dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) gopt_unset d Opt_WriteHie #else d @@ -290,7 +290,7 @@ dontWriteHieFiles d = setUpTypedHoles ::DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy -#if MIN_GHC_API_VERSION(8,8,0) +#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) @@ -312,7 +312,7 @@ nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) -- type HasSrcSpan x = () :: Constraint @@ -325,7 +325,7 @@ instance HasSrcSpan (GenLocated SrcSpan a) where -- getLoc :: GenLocated l a -> l -- getLoc = GHC.getLoc -#elif MIN_GHC_API_VERSION(8,8,0) +#elif MIN_VERSION_ghc(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan getLoc = GHC.getLoc @@ -349,14 +349,14 @@ addBootSuffixLocnOut locn #endif getModuleHash :: ModIface -> Fingerprint -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) getModuleHash = mi_mod_hash . mi_final_exts #else getModuleHash = mi_mod_hash #endif -- type PackageName = Packages.PackageName -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- NOTE: Since both the new and old version uses UnitId with different meaning, -- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous. type UnitId = Module.Unit @@ -491,7 +491,7 @@ disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = flip gopt_unset Opt_WarnIsError $ foldl' wopt_unset_fatal df [toEnum 0 ..] -#if !MIN_GHC_API_VERSION(8,8,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) } @@ -518,21 +518,21 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr -- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body dropForAll :: LHsType pass -> LHsType pass -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) dropForAll = snd . GHC.splitLHsForAllTyInvis #else dropForAll = snd . GHC.splitLHsForAllTy #endif pattern FunTy :: Type -> Type -> Type -#if MIN_GHC_API_VERSION(8, 10, 0) +#if MIN_VERSION_ghc(8, 10, 0) pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} #else pattern FunTy arg res <- TyCoRep.FunTy arg res #endif isQualifiedImport :: ImportDecl a -> Bool -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) isQualifiedImport ImportDecl{ideclQualified = NotQualified} = False isQualifiedImport ImportDecl{} = True #else @@ -587,6 +587,6 @@ stringToUnit = Module.stringToUnitId rtsUnit = Module.rtsUnitId #endif -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) #else #endif diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index aefa6f0b16..9252cce5ca 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -38,7 +38,7 @@ instance Show PackageFlag where show = prettyPrint instance Show InteractiveImport where show = prettyPrint instance Show PackageName where show = prettyPrint -#if !MIN_GHC_API_VERSION(9,0,1) +#if !MIN_VERSION_ghc(9,0,1) instance Show ComponentId where show = prettyPrint instance Show SourcePackageId where show = prettyPrint @@ -72,7 +72,7 @@ instance Show ParsedModule where instance NFData ModSummary where rnf = rwhnf -#if !MIN_GHC_API_VERSION(8,10,0) +#if !MIN_VERSION_ghc(8,10,0) instance NFData FastString where rnf = rwhnf #endif @@ -157,7 +157,7 @@ instance Show (Annotated ParsedSource) where instance NFData (Annotated ParsedSource) where rnf = rwhnf -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) instance (NFData HsModule) where #else instance (NFData (HsModule a)) where diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index a64a150bc5..c169a02717 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -194,7 +194,7 @@ documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQuali (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } #else , _detail = if ideclQualified then Just "qualified" else Nothing @@ -223,8 +223,8 @@ pprText = pack . showSDocUnsafe . ppr getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] getConNames' ConDeclH98 {con_name = name} = [name] getConNames' ConDeclGADT {con_names = names} = names -#if !MIN_GHC_API_VERSION(8,10,0) +#if !MIN_VERSION_ghc(8,10,0) getConNames' (XConDecl NoExt) = [] -#elif !MIN_GHC_API_VERSION(9,0,0) +#elif !MIN_VERSION_ghc(9,0,0) getConNames' (XConDecl x) = noExtCon x #endif diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 312150fb72..92c94a84cc 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -934,7 +934,7 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@ , mode <- [ ToQualified parensed qual | ExistingImp imps <- [modTarget] -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation -- nubOrd can't be used since SrcSpan is intentionally no Ord diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index e6386a5cd9..84587099a6 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -40,7 +40,7 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) import GHC.Tc.Module (tcRnImportDecls) #else import TcRnDriver (tcRnImportDecls) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index c089a25627..2943fe09e9 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -29,7 +29,7 @@ import HscTypes import Name import RdrName import Type -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) import Coercion import Pair import Predicate (isDictTy) @@ -270,7 +270,7 @@ mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI -- TODO: Do we want to use multiplicity here? else Prelude.filter (not . isDictTy) $ map scaledThing args | isPiTy t = getArgs $ snd (splitPiTys t) -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t = getArgs t #else diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 61cd91381e..347de66ee5 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -255,14 +255,14 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) where ni = nodeInfo' x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] -#if MIN_GHC_API_VERSION(8,8,0) +#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_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) HFunTy a b c -> getTypes [a,b,c] #else HFunTy a b -> getTypes [a,b] diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 4ecff71241..601045ddd3 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -156,7 +156,7 @@ getDocumentation sources targetName = fromMaybe [] $ do sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) ann = apiAnnComments . pm_annotations #else ann = fmap filterReal . snd . pm_annotations diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 71ae4c3555..d28846806c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -535,7 +535,7 @@ diagnosticTests = testGroup "diagnostics" , "foo = 1 {-|-}" ] _ <- createDoc "Foo.hs" "haskell" fooContent -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) -- Haddock parse errors are ignored on ghc-9.0.1 pure () #else @@ -3552,7 +3552,7 @@ findDefinitionAndHoverTests = let mkFindTests -- def hover look expect [ -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- It suggests either going to the constructor or to the field test broken yes fffL4 fff "field in record definition" #else @@ -3580,7 +3580,7 @@ findDefinitionAndHoverTests = let , test yes yes lclL33 lcb "listcomp lookup" , test yes yes mclL36 mcl "top-level fn 1st clause" , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , test yes yes spaceL37 space "top-level fn on space #1002" #else , test yes broken spaceL37 space "top-level fn on space #1002" @@ -3593,7 +3593,7 @@ findDefinitionAndHoverTests = let , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) , test no yes docL41 constr "type constraint in hover info #1012" #else , test no broken docL41 constr "type constraint in hover info #1012" @@ -4325,7 +4325,7 @@ highlightTests = testGroup "highlight" , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] , -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) expectFailBecause "Ghc9 highlights the constructor and not just this field" $ #endif testSessionWait "record" $ do @@ -4335,7 +4335,7 @@ highlightTests = testGroup "highlight" liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before [ -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else DocumentHighlight (R 4 4 4 11) (Just HkWrite) @@ -4346,7 +4346,7 @@ highlightTests = testGroup "highlight" liftIO $ highlights @?= List [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) -- Span is just the .. on 8.10, but Rec{..} before -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) , DocumentHighlight (R 4 8 4 10) (Just HkRead) #else , DocumentHighlight (R 4 4 4 11) (Just HkRead) @@ -4559,7 +4559,7 @@ ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) ignoreInWindowsForGHC88And810 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(9,0,0) ignoreInWindowsForGHC88And810 = ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8 and 8.10" #else @@ -4567,7 +4567,7 @@ ignoreInWindowsForGHC88And810 = id #endif ignoreInWindowsForGHC88 :: TestTree -> TestTree -#if MIN_GHC_API_VERSION(8,8,1) && !MIN_GHC_API_VERSION(8,10,1) +#if MIN_VERSION_ghc(8,8,1) && !MIN_VERSION_ghc(8,10,1) ignoreInWindowsForGHC88 = ignoreInWindowsBecause "tests are unreliable in windows for ghc 8.8" #else @@ -4739,7 +4739,7 @@ dependentFileTest = testGroup "addDependentFile" _ <-createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- String vs [Char] causes this change in error message [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] #else @@ -5008,7 +5008,7 @@ sessionDepsArePickedUp = testSession' -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- String vs [Char] causes this change in error message [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] #else @@ -5706,7 +5706,7 @@ assertJust s = \case -- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String listOfChar :: T.Text -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) listOfChar = "String" #else listOfChar = "[Char]" @@ -5714,7 +5714,7 @@ listOfChar = "[Char]" -- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did thDollarIdx :: Int -#if MIN_GHC_API_VERSION(9,0,1) +#if MIN_VERSION_ghc(9,0,1) thDollarIdx = 1 #else thDollarIdx = 0 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index ac69bf3caa..edfaa2a1c5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -141,7 +141,7 @@ import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) import GHC.Parser.Annotation (ApiAnns (apiAnnComments)) #else import GhcPlugins (interpWays, updateWays, @@ -149,7 +149,7 @@ import GhcPlugins (interpWays, updateWays, wayUnsetGeneralFlags) #endif -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan pattern RealSrcSpanAlready x = x #else @@ -305,7 +305,7 @@ runEvalCmd st EvalParams{..} = df <- getSessionDynFlags setInteractiveDynFlags $ (foldl xopt_set idflags evalExtensions) -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) { unitState = unitState df @@ -334,7 +334,7 @@ runEvalCmd st EvalParams{..} = #endif -- set up a custom log action -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) setLogAction $ \_df _wr _sev _span _doc -> defaultLogActionHPutStrDoc _df logHandle _doc #else diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 9579f9bfc2..0ce0152b1a 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -36,7 +36,7 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (pRELUDE) #else import PrelNames (pRELUDE) diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index c8a8847ddd..6670dca696 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -92,7 +92,7 @@ genForSig = GenComments {..} isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] collectKeys = keyFromTyVar 0 -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) comment = mkComment "-- ^ " badRealSrcSpan #else comment = mkComment "-- ^ " noSrcSpan @@ -115,7 +115,7 @@ genForRecord = GenComments {..} collectKeys = keyFromCon -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) comment = mkComment "-- | " badRealSrcSpan #else comment = mkComment "-- | " noSrcSpan @@ -156,7 +156,7 @@ cleanPriorComments x = x {annPriorComments = []} ----------------------------------------------------------------------------- keyFromTyVar :: Int -> LHsType GhcPs -> [AnnKey] -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) -- GHC9 HsFunTy has 4 arguments, we could extract this keyFromTyVar dep c@(L _ (HsFunTy _ _ x y)) #else diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 2c1ac68415..06355612e6 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -13,9 +13,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} #ifdef HLINT_ON_GHC_LIB -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc_lib(x,y,z) #else -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc(x,y,z) #endif module Ide.Plugin.Hlint @@ -103,7 +103,7 @@ import System.Environment (setEnv, -- --------------------------------------------------------------------- pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) pattern OldRealSrcSpan span <- RealSrcSpan span _ #else pattern OldRealSrcSpan span <- RealSrcSpan span diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index e23eecdbcf..e7db6ce256 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -297,7 +297,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = ] | L l r <- rds_rules, pos `isInsideSrcSpan` l, -#if MIN_GHC_API_VERSION(8,8,0) +#if MIN_VERSION_ghc(8,8,0) let HsRule {rd_name = L _ (_, rn)} = r, #else let HsRule _ (L _ (_,rn)) _ _ _ _ = r, @@ -552,7 +552,7 @@ toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} ideclSourceSrc = NoSourceText ideclExt = GHC.noExtField ideclAs = toMod <$> ideclAsString -#if MIN_GHC_API_VERSION(8,10,0) +#if MIN_VERSION_ghc(8,10,0) ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified #else ideclQualified = ideclQualifiedBool From 7da36016b824b5d1c58e517ba239b557b19afb1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 3 May 2021 10:04:19 +0800 Subject: [PATCH 48/86] Revert incorrect change to hlint code --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 06355612e6..2c1ac68415 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -13,9 +13,9 @@ {-# OPTIONS_GHC -Wno-orphans #-} #ifdef HLINT_ON_GHC_LIB -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) #else -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc(x,y,z) +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) #endif module Ide.Plugin.Hlint @@ -103,7 +103,7 @@ import System.Environment (setEnv, -- --------------------------------------------------------------------- pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan -#if MIN_VERSION_ghc(9,0,0) +#if MIN_GHC_API_VERSION(9,0,0) pattern OldRealSrcSpan span <- RealSrcSpan span _ #else pattern OldRealSrcSpan span <- RealSrcSpan span From d434ddb9a8367fcb086f92e9a5f8a6f267de73b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 3 May 2021 10:09:02 +0800 Subject: [PATCH 49/86] Remove remaining traces of GHC_LIB flag --- ghcide/src/Development/IDE/GHC/Util.hs | 3 +-- haskell-language-server.cabal | 1 - plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 -- plugins/hls-eval-plugin/include/ghc-api-version.h | 10 ---------- .../hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 1 - .../hls-explicit-imports-plugin.cabal | 1 - .../include/ghc-api-version.h | 10 ---------- .../hls-haddock-comments-plugin.cabal | 2 -- .../include/ghc-api-version.h | 10 ---------- .../src/Ide/Plugin/HaddockComments.hs | 1 - plugins/hls-retrie-plugin/hls-retrie-plugin.cabal | 1 - plugins/hls-retrie-plugin/include/ghc-api-version.h | 10 ---------- 12 files changed, 1 insertion(+), 51 deletions(-) delete mode 100644 plugins/hls-eval-plugin/include/ghc-api-version.h delete mode 100644 plugins/hls-explicit-imports-plugin/include/ghc-api-version.h delete mode 100644 plugins/hls-haddock-comments-plugin/include/ghc-api-version.h delete mode 100644 plugins/hls-retrie-plugin/include/ghc-api-version.h diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index a0f0e5404a..111f39e33a 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -#include "ghc-api-version.h" -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -262,7 +261,7 @@ dupHandleTo filepath h other_side -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment! -#if MIN_GHC_API_VERSION(9,0,0) +#if MIN_VERSION_ghc(9,0,0) dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev #else dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4de0bb4b50..1bdbdc0eb6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -349,7 +349,6 @@ executable haskell-language-server , transformers , unordered-containers - include-dirs: include default-language: Haskell2010 default-extensions: DataKinds, TypeOperators diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 49f5440af1..b0b34d4175 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -24,7 +24,6 @@ extra-source-files: test/testdata/*.hs test/testdata/*.lhs test/testdata/*.yaml - include/ghc-api-version.h flag pedantic description: Enable -Werror @@ -89,7 +88,6 @@ library ghc-options: -Werror default-language: Haskell2010 - include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-eval-plugin/include/ghc-api-version.h b/plugins/hls-eval-plugin/include/ghc-api-version.h deleted file mode 100644 index 11cabb3dc9..0000000000 --- a/plugins/hls-eval-plugin/include/ghc-api-version.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef GHC_API_VERSION_H -#define GHC_API_VERSION_H - -#ifdef GHC_LIB -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) -#else -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) -#endif - -#endif diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index edfaa2a1c5..b0602a3583 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -14,7 +14,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -#include "ghc-api-version.h" {- | A plugin inspired by the REPLoid feature of , 's Examples and Properties and . diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index b2af80b68f..97fb0b9f13 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -30,7 +30,6 @@ library , unordered-containers default-language: Haskell2010 - include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-explicit-imports-plugin/include/ghc-api-version.h b/plugins/hls-explicit-imports-plugin/include/ghc-api-version.h deleted file mode 100644 index ffe3029190..0000000000 --- a/plugins/hls-explicit-imports-plugin/include/ghc-api-version.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef GHC_API_VERSION_H -#define GHC_API_VERSION_H - -#ifdef GHC_LIB -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc_lib(x,y,z) -#else -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc(x,y,z) -#endif - -#endif diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index 21bb3094ea..c46ea8b42f 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -16,7 +16,6 @@ bug-reports: https://github.com/haskell/haskell-language-server/issues extra-source-files: LICENSE test/testdata/*.hs - include/ghc-api-version.h library exposed-modules: Ide.Plugin.HaddockComments @@ -37,7 +36,6 @@ library , unordered-containers default-language: Haskell2010 - include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h b/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h deleted file mode 100644 index 11cabb3dc9..0000000000 --- a/plugins/hls-haddock-comments-plugin/include/ghc-api-version.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef GHC_API_VERSION_H -#define GHC_API_VERSION_H - -#ifdef GHC_LIB -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) -#else -#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) -#endif - -#endif diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 6670dca696..554dea0836 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -5,7 +5,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} -#include "ghc-api-version.h" module Ide.Plugin.HaddockComments (descriptor) where diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index ee433ce52c..91a5a0c9ab 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -35,7 +35,6 @@ library , unordered-containers default-language: Haskell2010 - include-dirs: include default-extensions: DataKinds TypeOperators diff --git a/plugins/hls-retrie-plugin/include/ghc-api-version.h b/plugins/hls-retrie-plugin/include/ghc-api-version.h deleted file mode 100644 index ffe3029190..0000000000 --- a/plugins/hls-retrie-plugin/include/ghc-api-version.h +++ /dev/null @@ -1,10 +0,0 @@ -#ifndef GHC_API_VERSION_H -#define GHC_API_VERSION_H - -#ifdef GHC_LIB -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc_lib(x,y,z) -#else -#define MIN_VERSION_ghc(x,y,z) MIN_VERSION_ghc(x,y,z) -#endif - -#endif From c465a1e51aaaabf56dc7ef8f7fa801ef0abf8fdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 16:39:31 +0800 Subject: [PATCH 50/86] Add back ghc 9 to github workflow --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 70d49f958c..78b539e8b4 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -16,7 +16,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['8.10.4', '8.10.3', '8.10.2', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] + ghc: ['9.0.1', '8.10.4', '8.10.3', '8.10.2', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] os: [ubuntu-18.04, macOS-latest, windows-latest] exclude: - os: windows-latest From ddd4fea5ddc63094623add6d685a9f69f4857a41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 16:39:36 +0800 Subject: [PATCH 51/86] Revert "Add back ghc 9 to github workflow" This reverts commit c465a1e51aaaabf56dc7ef8f7fa801ef0abf8fdc. --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 78b539e8b4..70d49f958c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -16,7 +16,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ['9.0.1', '8.10.4', '8.10.3', '8.10.2', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] + ghc: ['8.10.4', '8.10.3', '8.10.2', '8.8.4', '8.8.3', '8.8.2', '8.6.5', '8.6.4'] os: [ubuntu-18.04, macOS-latest, windows-latest] exclude: - os: windows-latest From afef4bb2bc374b324900abc651f1d6452cb9da0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 29 Mar 2021 22:04:13 +0800 Subject: [PATCH 52/86] hie-compat: Add basic support for ghc-9.0.1 A tiny step towards #297 --- hie-compat/hie-compat.cabal | 12 +- hie-compat/src-ghc901/Compat/HieAst.hs | 2031 ++++++++++++++++++++++++ hie-compat/src-ghc901/Compat/HieBin.hs | 371 +++++ 3 files changed, 2411 insertions(+), 3 deletions(-) create mode 100644 hie-compat/src-ghc901/Compat/HieAst.hs create mode 100644 hie-compat/src-ghc901/Compat/HieBin.hs diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index 9778485028..9b1b5d2740 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -23,11 +23,15 @@ flag ghc-lib library default-language: Haskell2010 build-depends: - base < 4.15, array, bytestring, containers, directory, filepath, transformers + base < 4.16, array, bytestring, containers, directory, filepath, transformers if flag(ghc-lib) build-depends: ghc-lib else build-depends: ghc, ghc-boot + if (impl(ghc >= 9.0) && impl(ghc < 9.1)) + -- Used by src-reexport/... + build-depends: ghc-api-compat + ghc-options: -Wall -Wno-name-shadowing exposed-modules: Compat.HieAst @@ -38,8 +42,10 @@ library 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)) + 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) || flag(ghc-lib)) + if (impl(ghc > 8.9) && impl(ghc < 8.11)) hs-source-dirs: src-ghc810 src-reexport + if (impl(ghc >= 9.0) && impl(ghc < 9.1) || flag(ghc-lib)) + hs-source-dirs: src-ghc901 src-reexport diff --git a/hie-compat/src-ghc901/Compat/HieAst.hs b/hie-compat/src-ghc901/Compat/HieAst.hs new file mode 100644 index 0000000000..0b314f3d22 --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieAst.hs @@ -0,0 +1,2031 @@ +{- +Forked from GHC v9.0.1 to work around the readFile side effect in mkHiefile + +Main functions for .hie file generation +-} +{- HLINT ignore -} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Compat.HieAst ( mkHieFile, enrichHie ) where + +import GHC.Utils.Outputable(ppr) + +import GHC.Prelude + +import GHC.Types.Avail ( Avails ) +import GHC.Data.Bag ( Bag, bagToList ) +import GHC.Types.Basic +import GHC.Data.BooleanFormula +import GHC.Core.Class ( FunDep, className, classSCSelIds ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.FVs +import GHC.Core.DataCon ( dataConNonlinearType ) +import GHC.HsToCore ( deSugarExpr ) +import GHC.Types.FieldLabel +import GHC.Hs +import GHC.Driver.Types +import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Utils.Monad ( concatMapM, liftIO ) +import GHC.Types.Id ( isDataConId_maybe ) +import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.SrcLoc +import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) +import GHC.Core.Type ( mkVisFunTys, Type ) +import GHC.Core.Predicate +import GHC.Core.InstEnv +import GHC.Builtin.Types ( mkListTy, mkSumTy ) +import GHC.Tc.Types +import GHC.Tc.Types.Evidence +import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) +import GHC.Types.Var.Env +import GHC.Types.Unique +import GHC.Iface.Make ( mkIfaceExports ) +import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List ( foldl1' ) +import Control.Monad ( forM_ ) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +{- Note [Updating HieAst for changes in the GHC AST] + +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like + +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 + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in GHC.Iface.Ext.Ast. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in compiler/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +type VarMap a = DVarEnv (Var,a) +data HieState = HieState + { name_remapping :: NameEnv Id + , unlocated_ev_binds :: VarMap (S.Set ContextInfo) + -- These contain evidence bindings that we don't have a location for + -- These are placed at the top level Node in the HieAST after everything + -- else has been generated + -- This includes things like top level evidence bindings. + } + +addUnlocatedEvBind :: Var -> ContextInfo -> HieM () +addUnlocatedEvBind var ci = do + let go (a,b) (_,c) = (a,S.union b c) + lift $ modify' $ \s -> + s { unlocated_ev_binds = + extendDVarEnv_C go (unlocated_ev_binds s) + var (var,S.singleton ci) + } + +getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) +getUnlocatedEvBinds file = do + binds <- lift $ gets unlocated_ev_binds + org <- ask + let elts = dVarEnvElts binds + + mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) + + go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of + RealSrcSpan spn _ + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) + _ -> (mkNodeInfo e : xs,ys) + + (nis,asts) = foldr go ([],[]) elts + + pure $ (M.fromList nis, asts) + +initState :: HieState +initState = HieState emptyNameEnv emptyDVarEnv + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f + = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT NodeOrigin (StateT HieState Hsc) + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource + -> BS.ByteString -> Hsc HieFile +mkHieFile ms ts rs src = do + let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) + mkHieFileWithSource src_file src ms ts rs + +-- | Construct an 'HieFile' from the outputs of the typechecker but don't +-- read the source file again from disk. +mkHieFileWithSource :: FilePath + -> BS.ByteString + -> ModSummary + -> TcGblEnv + -> RenamedSource -> Hsc HieFile +mkHieFileWithSource src_file src ms ts rs = do + let tc_binds = tcg_binds ts + top_ev_binds = tcg_ev_binds ts + insts = tcg_insts ts + tcs = tcg_tcs ts + (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs top_ev_binds insts tcs = do + asts <- enrichHie ts rs top_ev_binds insts tcs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] + -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = + flip evalStateT initState $ flip runReaderT SourceInfo $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + -- Add Instance bindings + forM_ insts $ \i -> + addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) + -- Add class parent bindings + forM_ tcs $ \tc -> + case tyConClass_maybe tc of + Nothing -> pure () + Just c -> forM_ (classSCSelIds c) $ \v -> + addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) + let spanFile file children = case children of + [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + + modulify file xs' = do + + top_ev_asts <- + toHie $ EvBindContext ModuleScope Nothing + $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) + $ EvBinds ev_bs + + (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file + + let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts + span = spanFile file xs + + moduleInfo = SourcedNodeInfo + $ M.singleton SourceInfo + $ (simpleNodeInfo "Module" "Module") + {nodeIdentifiers = uloc_evs} + + moduleNode = Node moduleInfo span [] + + case mergeSortAsts $ moduleNode : xs of + [x] -> return x + xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) + + asts' <- sequence + $ M.mapWithKey modulify + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + let asts = HieASTs $ resolveTyVarScopes asts' + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = panic "XGRHS has no span" + +bindingsOnly :: [Context Name] -> HieM [HieAST a] +bindingsOnly [] = pure [] +bindingsOnly (C c n : xs) = do + org <- ask + rest <- bindingsOnly xs + pure $ case nameSrcSpan n of + RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> rest + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local transformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data EvBindContext a = EvBindContext Scope (Maybe Span) a + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr flag a] + -> [TVScoped (LHsTyVarBndr flag a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here + +This case in handled in the instance for HsPatSigType +-} + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance HasLoc a => HasLoc (FamEqn s a) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + +{- Note [Real DataCon Name] +The typechecker substitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span _) mname)) = do + org <- ask + pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | varUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of + Nothing -> varType name' + Just dc -> dataConNonlinearType dc + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just ty) + (S.singleton context))) + span + []] + C (EvidenceVarBind i _ sp) (L _ name) -> do + addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) + pure [] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') + | nameUnique name' == mkBuiltinUnique 1 -> pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise -> do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +evVarsOfTermList :: EvTerm -> [EvId] +evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e +evVarsOfTermList (EvTypeable _ ev) = + case ev of + EvTypeableTyCon _ e -> concatMap evVarsOfTermList e + EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] + EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] + EvTypeableTyLit e -> evVarsOfTermList e +evVarsOfTermList (EvFun{}) = [] + +instance ToHie (EvBindContext (Located TcEvBinds)) where + toHie (EvBindContext sc sp (L span (EvBinds bs))) + = concatMapM go $ bagToList bs + where + go evbind = do + let evDeps = evVarsOfTermList $ eb_rhs evbind + depNames = EvBindDeps $ map varName evDeps + concatM $ + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + (L span $ eb_lhs evbind)) + , toHie $ map (C EvidenceVarUse . L span) $ evDeps + ] + toHie _ = pure [] + +instance ToHie (Located HsWrapper) where + toHie (L osp wrap) + = case wrap of + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) + (WpCompose a b) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpFun a b _ _) -> concatM $ + [toHie (L osp a), toHie (L osp b)] + (WpEvLam a) -> + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) + $ L osp a + (WpEvApp a) -> + concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + _ -> pure [] + +instance HiePass p => HasType (LHsBind (GhcPass p)) where + getTypeNode (L spn bind) = + case hiePass @p of + HieRn -> makeNode bind spn + HieTc -> case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HiePass p => HasType (Located (Pat (GhcPass p))) where + getTypeNode (L spn pat) = + case hiePass @p of + HieRn -> makeNode pat spn + HieTc -> makeTypeNode pat spn (hsPatType pat) + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HiePass p => HasType (LHsExpr (GhcPass p)) where + getTypeNode e@(L spn e') = + case hiePass @p of + HieRn -> makeNode e' spn + HieTc -> + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr GhcTc -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + XExpr (WrapExpr {}) -> False + _ -> True + +data HiePassEv p where + HieRn :: HiePassEv 'Renamed + HieTc :: HiePassEv 'Typechecked + +class ( IsPass p + , HiePass (NoGhcTcPass p) + , ModifyState (IdGhcP p) + , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) + , Data (HsExpr (GhcPass p)) + , Data (HsCmd (GhcPass p)) + , Data (AmbiguousFieldOcc (GhcPass p)) + , Data (HsCmdTop (GhcPass p)) + , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) + , Data (HsSplice (GhcPass p)) + , Data (HsLocalBinds (GhcPass p)) + , Data (FieldOcc (GhcPass p)) + , Data (HsTupArg (GhcPass p)) + , Data (IPBind (GhcPass p)) + , ToHie (Context (Located (IdGhcP p))) + , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) + , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) + , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) + , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , HasRealDataConName (GhcPass p) + ) + => HiePass p where + hiePass :: HiePassEv p + +instance HiePass 'Renamed where + hiePass = HieRn +instance HiePass 'Typechecked where + hiePass = HieTc + +instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + , case hiePass @p of + HieTc -> toHie $ L span wrap + _ -> pure [] + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{ abs_exports = xs, abs_binds = binds + , abs_ev_binds = ev_binds + , abs_ev_vars = ev_vars } -> + [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] + (toHie $ fmap (BC context scope) binds) + , toHie $ map (L span . abe_wrap) xs + , toHie $ + map (EvBindContext (mkScope span) (getRealSpan span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScope span) + (getRealSpan span)) + . L span) ev_vars + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + +instance ( HiePass p + , ToHie (Located body) + , Data body + ) => ToHie (MatchGroup (GhcPass p) (Located body)) where + toHie mg = case mg of + MG{ mg_alts = (L span alts) , mg_origin = origin} -> + local (setOrigin origin) $ concatM + [ locOnly span + , toHie alts + ] + +setOrigin :: Origin -> NodeOrigin -> NodeOrigin +setOrigin FromSource _ = SourceInfo +setOrigin Generated _ = GeneratedInfo + +instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope patScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + patScope = mkScope $ getLoc pat + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + +instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( HiePass p + , Data body + , ToHie (Located body) + ) => ToHie (LMatch (GhcPass p) (Located body)) where + toHie (L span m ) = concatM $ node : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + where + node = case hiePass @p of + HieTc -> makeNode m span + HieRn -> makeNode m span + +instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> + case hiePass @p of + HieTc -> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + , let ev_binds = cpt_binds ext + ev_vars = cpt_dicts ext + wrap = cpt_wrap ext + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds + , toHie $ L ospan wrap + , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) + . L ospan) ev_vars + ] + ] + HieRn -> + [ toHie $ C Use con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , case hiePass @p of + HieTc -> + let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + sig + HieRn -> pure [] + ] + XPat e -> + case hiePass @p of + HieTc -> + let CoPat wrap pat _ = e + in [ toHie $ L ospan wrap + , toHie $ PS rsp scope pscope $ (L ospan pat) + ] +#if __GLASGOW_HASKELL__ < 811 + HieRn -> [] +#endif + where + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + + +instance ToHie (TScoped (HsPatSigType GhcRn)) where + toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + , toHie body + ] + -- See Note [Scoping Rules for SigPat] + +instance ( ToHie (Located body) + , HiePass p + , Data body + ) => ToHie (GRHSs (GhcPass p) (Located body)) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + +instance ( ToHie (Located body) + , HiePass a + , Data body + ) => ToHie (LGRHS (GhcPass a) (Located body)) where + toHie (L span g) = concatM $ node : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + where + node = case hiePass @a of + HieRn -> makeNode g span + HieTc -> makeNode g span + +instance HiePass p => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) + -- See Note [Real DataCon Name] + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsPragE _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ _wrap b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + XExpr x + | GhcTc <- ghcPass @p + , WrapExpr (HsWrap w a) <- x + -> [ toHie $ L mspan a + , toHie (L mspan w) + ] + | GhcTc <- ghcPass @p + , ExpansionExpr (HsExpanded _ b) <- x + -> [ toHie (L mspan b) + ] + | otherwise -> [] + +instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + +instance ( ToHie (Located body) + , Data body + , HiePass p + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ node : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + where + node = case hiePass @p of + HieTc -> makeNode stmt span + HieRn -> makeNode stmt span + +instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ ipbinds -> case ipbinds of + IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in + [ case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds + HieRn -> pure [] + , toHie $ map (RS sc) xs + ] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + +instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where + toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of + IPBind _ (Left _) expr -> [toHie expr] + IPBind _ (Right v) expr -> + [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) + $ L sp v + , toHie expr + ] + +instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie arg , HasLoc arg , Data arg + , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg , HasLoc arg , Data arg + , Data label + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan name) + ] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan name + ] + Ambiguous _name _ -> + [ ] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + Ambiguous var _ -> + [ toHie $ C (RecField c rhs) (L nspan var) + ] + +instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + +instance HiePass p => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdLamCase _ alts -> + [ toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (locOnly . getLoc) deftyps + , toHie deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie rhs, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn rhs)) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = locOnly span + +instance ToHie a => ToHie (HsScaled GhcRn a) where + toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , concatM $ [ bindingsOnly bindings + , toHie $ tvScopes resScope NoScope exp_vars ] + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + resScope = ResolvedScopes [ctxScope, rhsScope] + bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + where condecl_scope :: HsConDeclDetails p -> Scope + condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs + InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) + (mkLScope (hsScaledThing b)) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + +instance ToHie (LStandaloneKindSig GhcRn) where + toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + +instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where + toHie (SC (SI styp msp) (L sp sig)) = + case hiePass @p of + HieTc -> pure [] + HieRn -> concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , maybe (pure []) (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ tele body -> + let scope = mkScope $ getLoc body in + [ case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + toHie $ tvScopes tsc scope bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ w a b -> + [ toHie (arrowToHsType w) + , toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = locOnly sp + +instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + XSplice x -> case ghcPass @p of +#if __GLASGOW_HASKELL__ < 811 + GhcPs -> noExtCon x + GhcRn -> noExtCon x +#endif + GhcTc -> case x of + HsSplicedT _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (locOnly . getLoc) roles + ] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = concatM $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + where + goIE (hiding, (L sp liens)) = concatM $ + [ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] diff --git a/hie-compat/src-ghc901/Compat/HieBin.hs b/hie-compat/src-ghc901/Compat/HieBin.hs new file mode 100644 index 0000000000..75989759db --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieBin.hs @@ -0,0 +1,371 @@ +{- +Binary serialization for .hie files. +-} +{- HLINT ignore -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +module Compat.HieBin + ( readHieFile + , readHieFileWithVersion + , HieHeader + , writeHieFile + , HieName(..) + , toHieName + , HieFileResult(..) + , hieMagic + , hieNameOcc + , NameCacheUpdater(..) + ) +where + +import GHC.Settings.Utils ( maybeRead ) +import GHC.Settings.Config ( cProjectVersion ) +-- import GHC.Prelude +import GHC.Utils.Binary +import GHC.Iface.Binary ( getDictFastString ) +import GHC.Data.FastMutInt +import GHC.Data.FastString ( FastString ) +import GHC.Types.Name +import GHC.Types.Name.Cache +import GHC.Utils.Outputable +import GHC.Builtin.Utils +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply ( takeUniqFromSupply ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Iface.Env (NameCacheUpdater(..)) +-- 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 GHC.Iface.Ext.Types + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM FastString (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 initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) + 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_Directly 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_Directly out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM Name (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 + +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 "GHC.Iface.Ext.Binary.getHieName: invalid tag" From abdd43188b9284128138a5471b1aab572ee5327e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 29 Mar 2021 22:17:34 +0800 Subject: [PATCH 53/86] hie-compat: Remove dependency on ghc-api-compat --- hie-compat/hie-compat.cabal | 4 +--- hie-compat/src-ghc901/Compat/HieDebug.hs | 3 +++ hie-compat/src-ghc901/Compat/HieTypes.hs | 3 +++ hie-compat/src-ghc901/Compat/HieUtils.hs | 3 +++ 4 files changed, 10 insertions(+), 3 deletions(-) create mode 100644 hie-compat/src-ghc901/Compat/HieDebug.hs create mode 100644 hie-compat/src-ghc901/Compat/HieTypes.hs create mode 100644 hie-compat/src-ghc901/Compat/HieUtils.hs diff --git a/hie-compat/hie-compat.cabal b/hie-compat/hie-compat.cabal index 9b1b5d2740..7ceccc51ab 100644 --- a/hie-compat/hie-compat.cabal +++ b/hie-compat/hie-compat.cabal @@ -29,8 +29,6 @@ library else build-depends: ghc, ghc-boot if (impl(ghc >= 9.0) && impl(ghc < 9.1)) - -- Used by src-reexport/... - build-depends: ghc-api-compat ghc-options: -Wall -Wno-name-shadowing exposed-modules: @@ -47,5 +45,5 @@ library if (impl(ghc > 8.9) && impl(ghc < 8.11)) hs-source-dirs: src-ghc810 src-reexport if (impl(ghc >= 9.0) && impl(ghc < 9.1) || flag(ghc-lib)) - hs-source-dirs: src-ghc901 src-reexport + hs-source-dirs: src-ghc901 diff --git a/hie-compat/src-ghc901/Compat/HieDebug.hs b/hie-compat/src-ghc901/Compat/HieDebug.hs new file mode 100644 index 0000000000..9b8281c2bc --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieDebug.hs @@ -0,0 +1,3 @@ +module Compat.HieDebug + ( module GHC.Iface.Ext.Debug ) where +import GHC.Iface.Ext.Debug diff --git a/hie-compat/src-ghc901/Compat/HieTypes.hs b/hie-compat/src-ghc901/Compat/HieTypes.hs new file mode 100644 index 0000000000..36bb86abeb --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieTypes.hs @@ -0,0 +1,3 @@ +module Compat.HieTypes + ( module GHC.Iface.Ext.Types ) where +import GHC.Iface.Ext.Types diff --git a/hie-compat/src-ghc901/Compat/HieUtils.hs b/hie-compat/src-ghc901/Compat/HieUtils.hs new file mode 100644 index 0000000000..204a312039 --- /dev/null +++ b/hie-compat/src-ghc901/Compat/HieUtils.hs @@ -0,0 +1,3 @@ +module Compat.HieUtils + ( module GHC.Iface.Ext.Utils ) where +import GHC.Iface.Ext.Utils From b9f48d47c5af232855cd28850891629c105b1953 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 30 Mar 2021 12:14:20 +0800 Subject: [PATCH 54/86] hie-compat: Add more backwards compatability --- hie-compat/src-ghc901/Compat/HieDebug.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/hie-compat/src-ghc901/Compat/HieDebug.hs b/hie-compat/src-ghc901/Compat/HieDebug.hs index 9b8281c2bc..872da67c2b 100644 --- a/hie-compat/src-ghc901/Compat/HieDebug.hs +++ b/hie-compat/src-ghc901/Compat/HieDebug.hs @@ -1,3 +1,10 @@ module Compat.HieDebug - ( module GHC.Iface.Ext.Debug ) where + ( module GHC.Iface.Ext.Debug + , ppHie ) where import GHC.Iface.Ext.Debug + +import GHC.Iface.Ext.Types (HieAST) +import GHC.Utils.Outputable (Outputable(ppr), SDoc) + +ppHie :: Outputable a => HieAST a -> SDoc +ppHie = ppr From 7d9a32a1e4bde916cbdf9db86b71703992582c99 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 17:36:20 +0800 Subject: [PATCH 55/86] Disable CI for ghc9 --- .github/workflows/test.yml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f0bbdf0ab5..e6a619cf0d 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -33,13 +33,10 @@ jobs: strategy: fail-fast: true matrix: - ghc: ["9.0.1", "8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] + ghc: ["8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] os: [ubuntu-latest, macOS-latest] include: # only test supported ghc major versions - - os: ubuntu-latest - ghc: '9.0.1' - test: true - os: ubuntu-latest ghc: '8.10.4' test: true From 70542d60d0a291b72538c303bd61649abd2b305f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 17:43:05 +0800 Subject: [PATCH 56/86] Use newer version of apply-refact --- cabal.project | 6 ------ stack-9.0.1.yaml | 2 +- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index 241b0eb2f1..b528b1cf87 100644 --- a/cabal.project +++ b/cabal.project @@ -88,12 +88,6 @@ source-repository-package subdir: lsp-test -- https://github.com/haskell/lsp/pull/312 -source-repository-package - type: git - location: https://github.com/mpickering/apply-refact - tag: 0.9.2.0 --- https://github.com/mpickering/apply-refact/issues/107 - source-repository-package type: git location: https://github.com/diagrams/active diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index cfe80dfc1e..399e0f7005 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -25,7 +25,7 @@ ghc-options: "$everything": -haddock extra-deps: -- apply-refact-0.9.2.0 +- apply-refact-0.9.3.0 - base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 # Not newest (constraints-extras doesn't support 0.13 yet) From c682d9d9b348540322161fe2e4d74f40cb95fb7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 19:05:08 +0800 Subject: [PATCH 57/86] Don't needlessly duplicate code from ghc --- hie-compat/src-ghc901/Compat/HieAst.hs | 2014 +----------------------- 1 file changed, 9 insertions(+), 2005 deletions(-) diff --git a/hie-compat/src-ghc901/Compat/HieAst.hs b/hie-compat/src-ghc901/Compat/HieAst.hs index 0b314f3d22..26f315caef 100644 --- a/hie-compat/src-ghc901/Compat/HieAst.hs +++ b/hie-compat/src-ghc901/Compat/HieAst.hs @@ -4,279 +4,26 @@ Forked from GHC v9.0.1 to work around the readFile side effect in mkHiefile Main functions for .hie file generation -} {- HLINT ignore -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Compat.HieAst ( mkHieFile, enrichHie ) where -import GHC.Utils.Outputable(ppr) +import GHC.Data.Maybe (expectJust) +import GHC.Driver.Types +import GHC.Hs +import GHC.Tc.Types (TcGblEnv) +import GHC.Types.Avail (Avails) +import GHC.Unit.Module (ml_hs_file) -import GHC.Prelude +import GHC.Iface.Ext.Ast (enrichHie, mkHieFileWithSource) +import GHC.Iface.Ext.Types -import GHC.Types.Avail ( Avails ) -import GHC.Data.Bag ( Bag, bagToList ) -import GHC.Types.Basic -import GHC.Data.BooleanFormula -import GHC.Core.Class ( FunDep, className, classSCSelIds ) -import GHC.Core.Utils ( exprType ) -import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) -import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) -import GHC.Core.FVs -import GHC.Core.DataCon ( dataConNonlinearType ) -import GHC.HsToCore ( deSugarExpr ) -import GHC.Types.FieldLabel -import GHC.Hs -import GHC.Driver.Types -import GHC.Unit.Module ( ModuleName, ml_hs_file ) -import GHC.Utils.Monad ( concatMapM, liftIO ) -import GHC.Types.Id ( isDataConId_maybe ) -import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) -import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import GHC.Types.SrcLoc -import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) -import GHC.Core.Type ( mkVisFunTys, Type ) -import GHC.Core.Predicate -import GHC.Core.InstEnv -import GHC.Builtin.Types ( mkListTy, mkSumTy ) -import GHC.Tc.Types -import GHC.Tc.Types.Evidence -import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) -import GHC.Types.Var.Env -import GHC.Types.Unique -import GHC.Iface.Make ( mkIfaceExports ) -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Data.FastString +import qualified Data.ByteString as BS -import GHC.Iface.Ext.Types -import GHC.Iface.Ext.Utils -import qualified Data.Array as A -import qualified Data.ByteString as BS -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Data ( Data, Typeable ) -import Data.List ( foldl1' ) -import Control.Monad ( forM_ ) -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class ( lift ) - -{- Note [Updating HieAst for changes in the GHC AST] - -When updating the code in this file for changes in the GHC AST, you -need to pay attention to the following things: - -1) Symbols (Names/Vars/Modules) in the following categories: - - a) Symbols that appear in the source file that directly correspond to - something the user typed - b) Symbols that don't appear in the source, but should be in some sense - "visible" to a user, particularly via IDE tooling or the like. This - includes things like the names introduced by RecordWildcards (We record - all the names introduced by a (..) in HIE files), and will include implicit - parameters and evidence variables after one of my pending MRs lands. - -2) Subtrees that may contain such symbols, or correspond to a SrcSpan in - the file. This includes all `Located` things - -For 1), you need to call `toHie` for one of the following instances - -instance ToHie (Context (Located Name)) where ... -instance ToHie (Context (Located Var)) where ... -instance ToHie (IEContext (Located ModuleName)) where ... - -`Context` is a data type that looks like: - -data Context a = C ContextInfo a -- Used for names and bindings - -`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like - -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 - ... - -It is used to annotate symbols in the .hie files with some extra information on -the context in which they occur and should be fairly self explanatory. You need -to select one that looks appropriate for the symbol usage. In very rare cases, -you might need to extend this sum type if none of the cases seem appropriate. - -So, given a `Located Name` that is just being "used", and not defined at a -particular location, you would do the following: - - toHie $ C Use located_name - -If you select one that corresponds to a binding site, you will need to -provide a `Scope` and a `Span` for your binding. Both of these are basically -`SrcSpans`. - -The `SrcSpan` in the `Scope` is supposed to span over the part of the source -where the symbol can be legally allowed to occur. For more details on how to -calculate this, see Note [Capturing Scopes and other non local information] -in GHC.Iface.Ext.Ast. - -The binding `Span` is supposed to be the span of the entire binding for -the name. - -For a function definition `foo`: - -foo x = x + y - where y = x^2 - -The binding `Span` is the span of the entire function definition from `foo x` -to `x^2`. For a class definition, this is the span of the entire class, and -so on. If this isn't well defined for your bit of syntax (like a variable -bound by a lambda), then you can just supply a `Nothing` - -There is a test that checks that all symbols in the resulting HIE file -occur inside their stated `Scope`. This can be turned on by passing the --fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the -.hie file. - -You may also want to provide a test in testsuite/test/hiefile that includes -a file containing your new construction, and tests that the calculated scope -is valid (by using -fvalidate-ide-info) - -For subtrees in the AST that may contain symbols, the procedure is fairly -straightforward. If you are extending the GHC AST, you will need to provide a -`ToHie` instance for any new types you may have introduced in the AST. - -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): - - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - ... - HsApp _ a b -> - [ toHie a - , toHie b - ] - -If your subtree is `Located` or has a `SrcSpan` available, the output list -should contain a HieAst `Node` corresponding to the subtree. You can use -either `makeNode` or `getTypeNode` for this purpose, depending on whether it -makes sense to assign a `Type` to the subtree. After this, you just need -to concatenate the result of calling `toHie` on all subexpressions and -appropriately annotated symbols contained in the subtree. - -The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed -to work for both the renamed and typechecked source. `getTypeNode` is from -the `HasType` class defined in this file, and it has different instances -for `GhcTc` and `GhcRn` that allow it to access the type of the expression -when given a typechecked AST: - -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = ... -- Actually get the type for this expression -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type - -If your subtree doesn't have a span available, you can omit the `makeNode` -call and just recurse directly in to the subexpressions. - --} - --- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] , Maybe LHsDocString ) -type TypecheckedSource = LHsBinds GhcTc - - -{- Note [Name Remapping] -The Typechecker introduces new names for mono names in AbsBinds. -We don't care about the distinction between mono and poly bindings, -so we replace all occurrences of the mono name with the poly name. --} -type VarMap a = DVarEnv (Var,a) -data HieState = HieState - { name_remapping :: NameEnv Id - , unlocated_ev_binds :: VarMap (S.Set ContextInfo) - -- These contain evidence bindings that we don't have a location for - -- These are placed at the top level Node in the HieAST after everything - -- else has been generated - -- This includes things like top level evidence bindings. - } - -addUnlocatedEvBind :: Var -> ContextInfo -> HieM () -addUnlocatedEvBind var ci = do - let go (a,b) (_,c) = (a,S.union b c) - lift $ modify' $ \s -> - s { unlocated_ev_binds = - extendDVarEnv_C go (unlocated_ev_binds s) - var (var,S.singleton ci) - } - -getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) -getUnlocatedEvBinds file = do - binds <- lift $ gets unlocated_ev_binds - org <- ask - let elts = dVarEnvElts binds - - mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) - - go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of - RealSrcSpan spn _ - | srcSpanFile spn == file -> - let node = Node (mkSourcedNodeInfo org ni) spn [] - ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] - in (xs,node:ys) - _ -> (mkNodeInfo e : xs,ys) - - (nis,asts) = foldr go ([],[]) elts - - pure $ (M.fromList nis, asts) - -initState :: HieState -initState = HieState emptyNameEnv emptyDVarEnv - -class ModifyState a where -- See Note [Name Remapping] - addSubstitution :: a -> a -> HieState -> HieState - -instance ModifyState Name where - addSubstitution _ _ hs = hs - -instance ModifyState Id where - addSubstitution mono poly hs = - hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} - -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState -modifyState = foldr go id - where - go ABE{abe_poly=poly,abe_mono=mono} f - = addSubstitution mono poly . f - go _ f = f - -type HieM = ReaderT NodeOrigin (StateT HieState Hsc) -- | Construct an 'HieFile' from the outputs of the typechecker. mkHieFile :: ModSummary @@ -286,1746 +33,3 @@ mkHieFile :: ModSummary mkHieFile ms ts rs src = do let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) mkHieFileWithSource src_file src ms ts rs - --- | Construct an 'HieFile' from the outputs of the typechecker but don't --- read the source file again from disk. -mkHieFileWithSource :: FilePath - -> BS.ByteString - -> ModSummary - -> TcGblEnv - -> RenamedSource -> Hsc HieFile -mkHieFileWithSource src_file src ms ts rs = do - let tc_binds = tcg_binds ts - top_ev_binds = tcg_ev_binds ts - insts = tcg_insts ts - tcs = tcg_tcs ts - (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs - return $ HieFile - { hie_hs_file = src_file - , hie_module = ms_mod ms - , hie_types = arr - , hie_asts = asts' - -- mkIfaceExports sorts the AvailInfos for stability - , hie_exports = mkIfaceExports (tcg_exports ts) - , hie_hs_src = src - } - -getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -getCompressedAsts ts rs top_ev_binds insts tcs = do - asts <- enrichHie ts rs top_ev_binds insts tcs - return $ compressTypes asts - -enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> Hsc (HieASTs Type) -enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = - flip evalStateT initState $ flip runReaderT SourceInfo $ do - tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts - rasts <- processGrp hsGrp - imps <- toHie $ filter (not . ideclImplicit . unLoc) imports - exps <- toHie $ fmap (map $ IEC Export . fst) exports - -- Add Instance bindings - forM_ insts $ \i -> - addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) - -- Add class parent bindings - forM_ tcs $ \tc -> - case tyConClass_maybe tc of - Nothing -> pure () - Just c -> forM_ (classSCSelIds c) $ \v -> - addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) - let spanFile file children = case children of - [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) - _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) - (realSrcSpanEnd $ nodeSpan $ last children) - - flat_asts = concat - [ tasts - , rasts - , imps - , exps - ] - - modulify file xs' = do - - top_ev_asts <- - toHie $ EvBindContext ModuleScope Nothing - $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) - $ EvBinds ev_bs - - (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file - - let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts - span = spanFile file xs - - moduleInfo = SourcedNodeInfo - $ M.singleton SourceInfo - $ (simpleNodeInfo "Module" "Module") - {nodeIdentifiers = uloc_evs} - - moduleNode = Node moduleInfo span [] - - case mergeSortAsts $ moduleNode : xs of - [x] -> return x - xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) - - asts' <- sequence - $ M.mapWithKey modulify - $ M.fromListWith (++) - $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts - - let asts = HieASTs $ resolveTyVarScopes asts' - return asts - where - processGrp grp = concatM - [ toHie $ fmap (RS ModuleScope ) hs_valds grp - , toHie $ hs_splcds grp - , toHie $ hs_tyclds grp - , toHie $ hs_derivds grp - , toHie $ hs_fixds grp - , toHie $ hs_defds grp - , toHie $ hs_fords grp - , toHie $ hs_warnds grp - , toHie $ hs_annds grp - , toHie $ hs_ruleds grp - ] - -getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp _) = Just sp -getRealSpan _ = Nothing - -grhss_span :: GRHSs p body -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) -grhss_span (XGRHSs _) = panic "XGRHS has no span" - -bindingsOnly :: [Context Name] -> HieM [HieAST a] -bindingsOnly [] = pure [] -bindingsOnly (C c n : xs) = do - org <- ask - rest <- bindingsOnly xs - pure $ case nameSrcSpan n of - RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} - _ -> rest - -concatM :: Monad m => [m [a]] -> m [a] -concatM xs = concat <$> sequence xs - -{- Note [Capturing Scopes and other non local information] -toHie is a local transformation, but scopes of bindings cannot be known locally, -hence we have to push the relevant info down into the binding nodes. -We use the following types (*Context and *Scoped) to wrap things and -carry the required info -(Maybe Span) always carries the span of the entire binding, including rhs --} -data Context a = C ContextInfo a -- Used for names and bindings - -data RContext a = RC RecFieldContext a -data RFContext a = RFC RecFieldContext (Maybe Span) a --- ^ context for record fields - -data IEContext a = IEC IEType a --- ^ context for imports/exports - -data BindContext a = BC BindType Scope a --- ^ context for imports/exports - -data PatSynFieldContext a = PSC (Maybe Span) a --- ^ context for pattern synonym fields. - -data SigContext a = SC SigInfo a --- ^ context for type signatures - -data SigInfo = SI SigType (Maybe Span) - -data SigType = BindSig | ClassSig | InstSig - -data EvBindContext a = EvBindContext Scope (Maybe Span) a - -data RScoped a = RS Scope a --- ^ Scope spans over everything to the right of a, (mostly) not --- including a itself --- (Includes a in a few special cases like recursive do bindings) or --- let/where bindings - --- | Pattern scope -data PScoped a = PS (Maybe Span) - Scope -- ^ use site of the pattern - Scope -- ^ pattern to the right of a, not including a - a - deriving (Typeable, Data) -- Pattern Scope - -{- Note [TyVar Scopes] -Due to -XScopedTypeVariables, type variables can be in scope quite far from -their original binding. We resolve the scope of these type variables -in a separate pass --} -data TScoped a = TS TyVarScope a -- TyVarScope - -data TVScoped a = TVS TyVarScope Scope a -- TyVarScope --- ^ First scope remains constant --- Second scope is used to build up the scope of a tyvar over --- things to its right, ala RScoped - --- | Each element scopes over the elements to the right -listScopes :: Scope -> [Located a] -> [RScoped (Located a)] -listScopes _ [] = [] -listScopes rhsScope [pat] = [RS rhsScope pat] -listScopes rhsScope (pat : pats) = RS sc pat : pats' - where - pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLoc p - --- | 'listScopes' specialised to 'PScoped' things -patScopes - :: Maybe Span - -> Scope - -> Scope - -> [LPat (GhcPass p)] - -> [PScoped (LPat (GhcPass p))] -patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc a) $ - listScopes patScope xs - --- | 'listScopes' specialised to 'TVScoped' things -tvScopes - :: TyVarScope - -> Scope - -> [LHsTyVarBndr flag a] - -> [TVScoped (LHsTyVarBndr flag a)] -tvScopes tvScope rhsScope xs = - map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs - -{- Note [Scoping Rules for SigPat] -Explicitly quantified variables in pattern type signatures are not -brought into scope in the rhs, but implicitly quantified variables -are (HsWC and HsIB). -This is unlike other signatures, where explicitly quantified variables -are brought into the RHS Scope -For example -foo :: forall a. ...; -foo = ... -- a is in scope here - -bar (x :: forall a. a -> a) = ... -- a is not in scope here --- ^ a is in scope here (pattern body) - -bax (x :: a) = ... -- a is in scope here - -This case in handled in the instance for HsPatSigType --} - -class HasLoc a where - -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can - -- know what their implicit bindings are scoping over - loc :: a -> SrcSpan - -instance HasLoc thing => HasLoc (TScoped thing) where - loc (TS _ a) = loc a - -instance HasLoc thing => HasLoc (PScoped thing) where - loc (PS _ _ _ a) = loc a - -instance HasLoc (LHsQTyVars GhcRn) where - loc (HsQTvs _ vs) = loc vs - -instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where - loc (HsIB _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where - loc (HsWC _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc (Located a) where - loc (L l _) = l - -instance HasLoc a => HasLoc [a] where - loc [] = noSrcSpan - loc xs = foldl1' combineSrcSpans $ map loc xs - -instance HasLoc a => HasLoc (FamEqn s a) where - loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, loc b, loc c] - loc _ = noSrcSpan -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where - loc (HsValArg tm) = loc tm - loc (HsTypeArg _ ty) = loc ty - loc (HsArgPar sp) = sp - -instance HasLoc (HsDataDefn GhcRn) where - loc def@(HsDataDefn{}) = loc $ dd_cons def - -- Only used for data family instances, so we only need rhs - -- Most probably the rest will be unhelpful anyway - -{- Note [Real DataCon Name] -The typechecker substitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - --- | The main worker class --- See Note [Updating HieAst for changes in the GHC AST] for more information --- on how to add/modify instances for this. -class ToHie a where - toHie :: a -> HieM [HieAST Type] - --- | Used to collect type info -class HasType a where - getTypeNode :: a -> HieM [HieAST Type] - -instance (ToHie a) => ToHie [a] where - toHie = concatMapM toHie - -instance (ToHie a) => ToHie (Bag a) where - toHie = toHie . bagToList - -instance (ToHie a) => ToHie (Maybe a) where - toHie = maybe (pure []) toHie - -instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span _) mname)) = do - org <- ask - pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] - where details = mempty{identInfo = S.singleton (IEThing c)} - idents = M.singleton (Left mname) details - toHie _ = pure [] - -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | varUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - ty = case isDataConId_maybe name' of - Nothing -> varType name' - Just dc -> dataConNonlinearType dc - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right $ varName name) - (IdentifierDetails (Just ty) - (S.singleton context))) - span - []] - C (EvidenceVarBind i _ sp) (L _ name) -> do - addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) - pure [] - _ -> pure [] - -instance ToHie (Context (Located Name)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | nameUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] - _ -> pure [] - -evVarsOfTermList :: EvTerm -> [EvId] -evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e -evVarsOfTermList (EvTypeable _ ev) = - case ev of - EvTypeableTyCon _ e -> concatMap evVarsOfTermList e - EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] - EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] - EvTypeableTyLit e -> evVarsOfTermList e -evVarsOfTermList (EvFun{}) = [] - -instance ToHie (EvBindContext (Located TcEvBinds)) where - toHie (EvBindContext sc sp (L span (EvBinds bs))) - = concatMapM go $ bagToList bs - where - go evbind = do - let evDeps = evVarsOfTermList $ eb_rhs evbind - depNames = EvBindDeps $ map varName evDeps - concatM $ - [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) - (L span $ eb_lhs evbind)) - , toHie $ map (C EvidenceVarUse . L span) $ evDeps - ] - toHie _ = pure [] - -instance ToHie (Located HsWrapper) where - toHie (L osp wrap) - = case wrap of - (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) - (WpCompose a b) -> concatM $ - [toHie (L osp a), toHie (L osp b)] - (WpFun a b _ _) -> concatM $ - [toHie (L osp a), toHie (L osp b)] - (WpEvLam a) -> - toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) - $ L osp a - (WpEvApp a) -> - concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a - _ -> pure [] - -instance HiePass p => HasType (LHsBind (GhcPass p)) where - getTypeNode (L spn bind) = - case hiePass @p of - HieRn -> makeNode bind spn - HieTc -> case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn - -instance HiePass p => HasType (Located (Pat (GhcPass p))) where - getTypeNode (L spn pat) = - case hiePass @p of - HieRn -> makeNode pat spn - HieTc -> makeTypeNode pat spn (hsPatType pat) - --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. --- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 -instance HiePass p => HasType (LHsExpr (GhcPass p)) where - getTypeNode e@(L spn e') = - case hiePass @p of - HieRn -> makeNode e' spn - HieTc -> - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) - - HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) - - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty - - _ -> Nothing - - in - case tyOpt of - Just t -> makeTypeNode e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn - - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res - - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr GhcTc -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - XExpr (WrapExpr {}) -> False - _ -> True - -data HiePassEv p where - HieRn :: HiePassEv 'Renamed - HieTc :: HiePassEv 'Typechecked - -class ( IsPass p - , HiePass (NoGhcTcPass p) - , ModifyState (IdGhcP p) - , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) - , Data (HsExpr (GhcPass p)) - , Data (HsCmd (GhcPass p)) - , Data (AmbiguousFieldOcc (GhcPass p)) - , Data (HsCmdTop (GhcPass p)) - , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) - , Data (HsSplice (GhcPass p)) - , Data (HsLocalBinds (GhcPass p)) - , Data (FieldOcc (GhcPass p)) - , Data (HsTupArg (GhcPass p)) - , Data (IPBind (GhcPass p)) - , ToHie (Context (Located (IdGhcP p))) - , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) - , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) - , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) - , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) - , HasRealDataConName (GhcPass p) - ) - => HiePass p where - hiePass :: HiePassEv p - -instance HiePass 'Renamed where - hiePass = HieRn -instance HiePass 'Typechecked where - hiePass = HieTc - -instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where - toHie (BC context scope b@(L span bind)) = - concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> - [ toHie $ C (ValBind context scope $ getRealSpan span) name - , toHie matches - , case hiePass @p of - HieTc -> toHie $ L span wrap - _ -> pure [] - ] - PatBind{pat_lhs = lhs, pat_rhs = rhs} -> - [ toHie $ PS (getRealSpan span) scope NoScope lhs - , toHie rhs - ] - VarBind{var_rhs = expr} -> - [ toHie expr - ] - AbsBinds{ abs_exports = xs, abs_binds = binds - , abs_ev_binds = ev_binds - , abs_ev_vars = ev_vars } -> - [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] - (toHie $ fmap (BC context scope) binds) - , toHie $ map (L span . abe_wrap) xs - , toHie $ - map (EvBindContext (mkScope span) (getRealSpan span) - . L span) ev_binds - , toHie $ - map (C (EvidenceVarBind EvSigBind - (mkScope span) - (getRealSpan span)) - . L span) ev_vars - ] - PatSynBind _ psb -> - [ toHie $ L span psb -- PatSynBinds only occur at the top level - ] - -instance ( HiePass p - , ToHie (Located body) - , Data body - ) => ToHie (MatchGroup (GhcPass p) (Located body)) where - toHie mg = case mg of - MG{ mg_alts = (L span alts) , mg_origin = origin} -> - local (setOrigin origin) $ concatM - [ locOnly span - , toHie alts - ] - -setOrigin :: Origin -> NodeOrigin -> NodeOrigin -setOrigin FromSource _ = SourceInfo -setOrigin Generated _ = GeneratedInfo - -instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where - toHie (L sp psb) = concatM $ case psb of - PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> - [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var - , toHie $ toBind dets - , toHie $ PS Nothing lhsScope patScope pat - , toHie dir - ] - where - lhsScope = combineScopes varScope detScope - varScope = mkLScope var - patScope = mkScope $ getLoc pat - detScope = case dets of - (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args - (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) - (RecCon r) -> foldr go NoScope r - go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope a) (mkLScope b) - detSpan = case detScope of - LocalScope a -> Just a - _ -> Nothing - toBind (PrefixCon args) = PrefixCon $ map (C Use) args - toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) - toBind (RecCon r) = RecCon $ map (PSC detSpan) r - -instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where - toHie dir = case dir of - ExplicitBidirectional mg -> toHie mg - _ -> pure [] - -instance ( HiePass p - , Data body - , ToHie (Located body) - ) => ToHie (LMatch (GhcPass p) (Located body)) where - toHie (L span m ) = concatM $ node : case m of - Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> - [ toHie mctx - , let rhsScope = mkScope $ grhss_span grhss - in toHie $ patScopes Nothing rhsScope NoScope pats - , toHie grhss - ] - where - node = case hiePass @p of - HieTc -> makeNode m span - HieRn -> makeNode m span - -instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where - toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name - toHie (StmtCtxt a) = toHie a - toHie _ = pure [] - -instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where - toHie (PatGuard a) = toHie a - toHie (ParStmtCtxt a) = toHie a - toHie (TransStmtCtxt a) = toHie a - toHie _ = pure [] - -instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(L ospan opat)) = - concatM $ getTypeNode lpat : case opat of - WildPat _ -> - [] - VarPat _ lname -> - [ toHie $ C (PatternBind scope pscope rsp) lname - ] - LazyPat _ p -> - [ toHie $ PS rsp scope pscope p - ] - AsPat _ lname pat -> - [ toHie $ C (PatternBind scope - (combineScopes (mkLScope pat) pscope) - rsp) - lname - , toHie $ PS rsp scope pscope pat - ] - ParPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - BangPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - ListPat _ pats -> - [ toHie $ patScopes rsp scope pscope pats - ] - TuplePat _ pats _ -> - [ toHie $ patScopes rsp scope pscope pats - ] - SumPat _ pat _ _ -> - [ toHie $ PS rsp scope pscope pat - ] - ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> - case hiePass @p of - HieTc -> - [ toHie $ C Use $ fmap conLikeName con - , toHie $ contextify dets - , let ev_binds = cpt_binds ext - ev_vars = cpt_dicts ext - wrap = cpt_wrap ext - evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope - in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds - , toHie $ L ospan wrap - , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) - . L ospan) ev_vars - ] - ] - HieRn -> - [ toHie $ C Use con - , toHie $ contextify dets - ] - ViewPat _ expr pat -> - [ toHie expr - , toHie $ PS rsp scope pscope pat - ] - SplicePat _ sp -> - [ toHie $ L ospan sp - ] - LitPat _ _ -> - [] - NPat _ _ _ _ -> - [] - NPlusKPat _ n _ _ _ _ -> - [ toHie $ C (PatternBind scope pscope rsp) n - ] - SigPat _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , case hiePass @p of - HieTc -> - let cscope = mkLScope pat in - toHie $ TS (ResolvedScopes [cscope, scope, pscope]) - sig - HieRn -> pure [] - ] - XPat e -> - case hiePass @p of - HieTc -> - let CoPat wrap pat _ = e - in [ toHie $ L ospan wrap - , toHie $ PS rsp scope pscope $ (L ospan pat) - ] -#if __GLASGOW_HASKELL__ < 811 - HieRn -> [] -#endif - where - contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) - -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) - contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args - contextify (InfixCon a b) = InfixCon a' b' - where [a', b'] = patScopes rsp scope pscope [a,b] - contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r - contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a - where - go (RS fscope (L spn (HsRecField lbl pat pun))) = - L spn $ HsRecField lbl (PS rsp scope fscope pat) pun - scoped_fds = listScopes pscope fds - - -instance ToHie (TScoped (HsPatSigType GhcRn)) where - toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) - , toHie body - ] - -- See Note [Scoping Rules for SigPat] - -instance ( ToHie (Located body) - , HiePass p - , Data body - ) => ToHie (GRHSs (GhcPass p) (Located body)) where - toHie grhs = concatM $ case grhs of - GRHSs _ grhss binds -> - [ toHie grhss - , toHie $ RS (mkScope $ grhss_span grhs) binds - ] - -instance ( ToHie (Located body) - , HiePass a - , Data body - ) => ToHie (LGRHS (GhcPass a) (Located body)) where - toHie (L span g) = concatM $ node : case g of - GRHS _ guards body -> - [ toHie $ listScopes (mkLScope body) guards - , toHie body - ] - where - node = case hiePass @a of - HieRn -> makeNode g span - HieTc -> makeNode g span - -instance HiePass p => ToHie (LHsExpr (GhcPass p)) where - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsUnboundVar _ _ -> - [] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - HsRecFld _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) - ] - HsOverLabel _ _ _ -> [] - HsIPVar _ _ -> [] - HsOverLit _ _ -> [] - HsLit _ _ -> [] - HsLam _ mg -> - [ toHie mg - ] - HsLamCase _ mg -> - [ toHie mg - ] - HsApp _ a b -> - [ toHie a - , toHie b - ] - HsAppType _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes []) sig - ] - OpApp _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - NegApp _ a _ -> - [ toHie a - ] - HsPar _ a -> - [ toHie a - ] - SectionL _ a b -> - [ toHie a - , toHie b - ] - SectionR _ a b -> - [ toHie a - , toHie b - ] - ExplicitTuple _ args _ -> - [ toHie args - ] - ExplicitSum _ _ _ expr -> - [ toHie expr - ] - HsCase _ expr matches -> - [ toHie expr - , toHie matches - ] - HsIf _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsMultiIf _ grhss -> - [ toHie grhss - ] - HsLet _ binds expr -> - [ toHie $ RS (mkLScope expr) binds - , toHie expr - ] - HsDo _ _ (L ispan stmts) -> - [ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - ExplicitList _ _ exprs -> - [ toHie exprs - ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) - -- See Note [Real DataCon Name] - , toHie $ RC RecFieldAssign $ binds - ] - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> - [ toHie expr - , toHie $ map (RC RecFieldAssign) upds - ] - ExprWithTySig _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScope expr]) sig - ] - ArithSeq _ _ info -> - [ toHie info - ] - HsPragE _ _ expr -> - [ toHie expr - ] - HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat - , toHie cmdtop - ] - HsStatic _ expr -> - [ toHie expr - ] - HsTick _ _ expr -> - [ toHie expr - ] - HsBinTick _ _ _ expr -> - [ toHie expr - ] - HsBracket _ b -> - [ toHie b - ] - HsRnBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsTcBracketOut _ _wrap b p -> - [ toHie b - , toHie p - ] - HsSpliceE _ x -> - [ toHie $ L mspan x - ] - XExpr x - | GhcTc <- ghcPass @p - , WrapExpr (HsWrap w a) <- x - -> [ toHie $ L mspan a - , toHie (L mspan w) - ] - | GhcTc <- ghcPass @p - , ExpansionExpr (HsExpanded _ b) <- x - -> [ toHie (L mspan b) - ] - | otherwise -> [] - -instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where - toHie (L span arg) = concatM $ makeNode arg span : case arg of - Present _ expr -> - [ toHie expr - ] - Missing _ -> [] - -instance ( ToHie (Located body) - , Data body - , HiePass p - ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where - toHie (RS scope (L span stmt)) = concatM $ node : case stmt of - LastStmt _ body _ _ -> - [ toHie body - ] - BindStmt _ pat body -> - [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat - , toHie body - ] - ApplicativeStmt _ stmts _ -> - [ concatMapM (toHie . RS scope . snd) stmts - ] - BodyStmt _ body _ _ -> - [ toHie body - ] - LetStmt _ binds -> - [ toHie $ RS scope binds - ] - ParStmt _ parstmts _ _ -> - [ concatMapM (\(ParStmtBlock _ stmts _ _) -> - toHie $ listScopes NoScope stmts) - parstmts - ] - TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> - [ toHie $ listScopes scope stmts - , toHie using - , toHie by - ] - RecStmt {recS_stmts = stmts} -> - [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts - ] - where - node = case hiePass @p of - HieTc -> makeNode stmt span - HieRn -> makeNode stmt span - -instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where - toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of - EmptyLocalBinds _ -> [] - HsIPBinds _ ipbinds -> case ipbinds of - IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in - [ case hiePass @p of - HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds - HieRn -> pure [] - , toHie $ map (RS sc) xs - ] - HsValBinds _ valBinds -> - [ toHie $ RS (combineScopes scope $ mkScope sp) - valBinds - ] - -instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where - toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of - IPBind _ (Left _) expr -> [toHie expr] - IPBind _ (Right v) expr -> - [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) - $ L sp v - , toHie expr - ] - -instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where - toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> - [ toHie $ fmap (BC RegularBind sc) binds - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - XValBindsLR x -> [ toHie $ RS sc x ] - -instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - -instance ( ToHie arg , HasLoc arg , Data arg - , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where - toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields - -instance ( ToHie (RFContext (Located label)) - , ToHie arg , HasLoc arg , Data arg - , Data label - ) => ToHie (RContext (LHsRecField' label arg)) where - toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of - HsRecField label expr _ -> - [ toHie $ RFC c (getRealSpan $ loc expr) label - , toHie expr - ] - -instance ToHie (RFContext (LFieldOcc GhcRn)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> - [ toHie $ C (RecField c rhs) (L nspan name) - ] - -instance ToHie (RFContext (LFieldOcc GhcTc)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous name _ -> - [ toHie $ C (RecField c rhs) $ L nspan name - ] - Ambiguous _name _ -> - [ ] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - Ambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - -instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM - [ toHie $ PS Nothing sc NoScope pat - , toHie expr - ] - toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM - [ toHie $ listScopes NoScope stmts - , toHie $ PS Nothing sc NoScope pat - ] - -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where - toHie (PrefixCon args) = toHie args - toHie (RecCon rec) = toHie rec - toHie (InfixCon a b) = concatM [ toHie a, toHie b] - -instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where - toHie (L span top) = concatM $ makeNode top span : case top of - HsCmdTop _ cmd -> - [ toHie cmd - ] - -instance HiePass p => ToHie (LHsCmd (GhcPass p)) where - toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of - HsCmdArrApp _ a b _ _ -> - [ toHie a - , toHie b - ] - HsCmdArrForm _ a _ _ cmdtops -> - [ toHie a - , toHie cmdtops - ] - HsCmdApp _ a b -> - [ toHie a - , toHie b - ] - HsCmdLam _ mg -> - [ toHie mg - ] - HsCmdPar _ a -> - [ toHie a - ] - HsCmdCase _ expr alts -> - [ toHie expr - , toHie alts - ] - HsCmdLamCase _ alts -> - [ toHie alts - ] - HsCmdIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsCmdLet _ binds cmd' -> - [ toHie $ RS (mkLScope cmd') binds - , toHie cmd' - ] - HsCmdDo _ (L ispan stmts) -> - [ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - XCmd _ -> [] - -instance ToHie (TyClGroup GhcRn) where - toHie TyClGroup{ group_tyclds = classes - , group_roles = roles - , group_kisigs = sigs - , group_instds = instances } = - concatM - [ toHie classes - , toHie sigs - , toHie roles - , toHie instances - ] - -instance ToHie (LTyClDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamDecl {tcdFam = fdecl} -> - [ toHie (L span fdecl) - ] - SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> - [ toHie $ C (Decl SynDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars - , toHie typ - ] - DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> - [ toHie $ C (Decl DataDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars - , toHie defn - ] - where - quant_scope = mkLScope $ dd_ctxt defn - rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScope $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn - deriv_sc = mkLScope $ dd_derivs defn - ClassDecl { tcdCtxt = context - , tcdLName = name - , tcdTyVars = vars - , tcdFDs = deps - , tcdSigs = sigs - , tcdMeths = meths - , tcdATs = typs - , tcdATDefs = deftyps - } -> - [ toHie $ C (Decl ClassDec $ getRealSpan span) name - , toHie context - , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars - , toHie deps - , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs - , toHie $ fmap (BC InstanceBind ModuleScope) meths - , toHie typs - , concatMapM (locOnly . getLoc) deftyps - , toHie deftyps - ] - where - context_scope = mkLScope context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - -instance ToHie (LFamilyDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamilyDecl _ info name vars _ sig inj -> - [ toHie $ C (Decl FamDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [rhsSpan]) vars - , toHie info - , toHie $ RS injSpan sig - , toHie inj - ] - where - rhsSpan = sigSpan `combineScopes` injSpan - sigSpan = mkScope $ getLoc sig - injSpan = maybe NoScope (mkScope . getLoc) inj - -instance ToHie (FamilyInfo GhcRn) where - toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (locOnly . getLoc) eqns - , toHie $ map go eqns - ] - where - go (L l ib) = TS (ResolvedScopes [mkScope l]) ib - toHie _ = pure [] - -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where - toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of - NoSig _ -> - [] - KindSig _ k -> - [ toHie k - ] - TyVarSig _ bndr -> - [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr - ] - -instance ToHie (Located (FunDep (Located Name))) where - toHie (L span fd@(lhs, rhs)) = concatM $ - [ makeNode fd span - , toHie $ map (C Use) lhs - , toHie $ map (C Use) rhs - ] - -instance (ToHie rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where - toHie (TS _ f) = toHie f - -instance (ToHie rhs, HasLoc rhs) - => ToHie (FamEqn GhcRn rhs) where - toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc rhs) - -instance ToHie (LInjectivityAnn GhcRn) where - toHie (L span ann) = concatM $ makeNode ann span : case ann of - InjectivityAnn lhs rhs -> - [ toHie $ C Use lhs - , toHie $ map (C Use) rhs - ] - -instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM - [ toHie ctx - , toHie mkind - , toHie cons - , toHie derivs - ] - -instance ToHie (HsDeriving GhcRn) where - toHie (L span clauses) = concatM - [ locOnly span - , toHie clauses - ] - -instance ToHie (LHsDerivingClause GhcRn) where - toHie (L span cl) = concatM $ makeNode cl span : case cl of - HsDerivingClause _ strat (L ispan tys) -> - [ toHie strat - , locOnly ispan - , toHie $ map (TS (ResolvedScopes [])) tys - ] - -instance ToHie (Located (DerivStrategy GhcRn)) where - toHie (L span strat) = concatM $ makeNode strat span : case strat of - StockStrategy -> [] - AnyclassStrategy -> [] - NewtypeStrategy -> [] - ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] - -instance ToHie (Located OverlapMode) where - toHie (L span _) = locOnly span - -instance ToHie a => ToHie (HsScaled GhcRn a) where - toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] - -instance ToHie (LConDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars - , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> - [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , concatM $ [ bindingsOnly bindings - , toHie $ tvScopes resScope NoScope exp_vars ] - , toHie ctx - , toHie args - , toHie typ - ] - where - rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope args - tyScope = mkLScope typ - resScope = ResolvedScopes [ctxScope, rhsScope] - bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars - ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> - [ toHie $ C (Decl ConDec $ getRealSpan span) name - , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars - , toHie ctx - , toHie dets - ] - where - rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope dets - where condecl_scope :: HsConDeclDetails p -> Scope - condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs - InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) - (mkLScope (hsScaledThing b)) - RecCon x -> mkLScope x - -instance ToHie (Located [LConDeclField GhcRn]) where - toHie (L span decls) = concatM $ - [ locOnly span - , toHie decls - ] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where - toHie (TS sc (HsIB ibrn a)) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn - , toHie $ TS sc a - ] - where span = loc a - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where - toHie (TS sc (HsWC names a)) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names - , toHie $ TS sc a - ] - where span = loc a - -instance ToHie (LStandaloneKindSig GhcRn) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] - -instance ToHie (StandaloneKindSig GhcRn) where - toHie sig = concatM $ case sig of - StandaloneKindSig _ name typ -> - [ toHie $ C TyDecl name - , toHie $ TS (ResolvedScopes []) typ - ] - -instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where - toHie (SC (SI styp msp) (L sp sig)) = - case hiePass @p of - HieTc -> pure [] - HieRn -> concatM $ makeNode sig sp : case sig of - TypeSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - PatSynSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - ClassOpSig _ _ names typ -> - [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names - _ -> toHie $ map (C $ TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ - ] - IdSig _ _ -> [] - FixSig _ fsig -> - [ toHie $ L sp fsig - ] - InlineSig _ name _ -> - [ toHie $ (C Use) name - ] - SpecSig _ name typs _ -> - [ toHie $ (C Use) name - , toHie $ map (TS (ResolvedScopes [])) typs - ] - SpecInstSig _ _ typ -> - [ toHie $ TS (ResolvedScopes []) typ - ] - MinimalSig _ _ form -> - [ toHie form - ] - SCCFunSig _ _ name mtxt -> - [ toHie $ (C Use) name - , maybe (pure []) (locOnly . getLoc) mtxt - ] - CompleteMatchSig _ _ (L ispan names) typ -> - [ locOnly ispan - , toHie $ map (C Use) names - , toHie $ fmap (C Use) typ - ] - -instance ToHie (LHsType GhcRn) where - toHie x = toHie $ TS (ResolvedScopes []) x - -instance ToHie (TScoped (LHsType GhcRn)) where - toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of - HsForAllTy _ tele body -> - let scope = mkScope $ getLoc body in - [ case tele of - HsForAllVis { hsf_vis_bndrs = bndrs } -> - toHie $ tvScopes tsc scope bndrs - HsForAllInvis { hsf_invis_bndrs = bndrs } -> - toHie $ tvScopes tsc scope bndrs - , toHie body - ] - HsQualTy _ ctx body -> - [ toHie ctx - , toHie body - ] - HsTyVar _ _ var -> - [ toHie $ C Use var - ] - HsAppTy _ a b -> - [ toHie a - , toHie b - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - HsFunTy _ w a b -> - [ toHie (arrowToHsType w) - , toHie a - , toHie b - ] - HsListTy _ a -> - [ toHie a - ] - HsTupleTy _ _ tys -> - [ toHie tys - ] - HsSumTy _ tys -> - [ toHie tys - ] - HsOpTy _ a op b -> - [ toHie a - , toHie $ C Use op - , toHie b - ] - HsParTy _ a -> - [ toHie a - ] - HsIParamTy _ ip ty -> - [ toHie ip - , toHie ty - ] - HsKindSig _ a b -> - [ toHie a - , toHie b - ] - HsSpliceTy _ a -> - [ toHie $ L span a - ] - HsDocTy _ a _ -> - [ toHie a - ] - HsBangTy _ _ ty -> - [ toHie ty - ] - HsRecTy _ fields -> - [ toHie fields - ] - HsExplicitListTy _ _ tys -> - [ toHie tys - ] - HsExplicitTupleTy _ tys -> - [ toHie tys - ] - HsTyLit _ _ -> [] - HsWildCardTy _ -> [] - HsStarTy _ _ -> [] - XHsType _ -> [] - -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where - toHie (HsValArg tm) = toHie tm - toHie (HsTypeArg _ ty) = toHie ty - toHie (HsArgPar sp) = locOnly sp - -instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where - toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ _ var -> - [ toHie $ C (TyVarBind sc tsc) var - ] - KindedTyVar _ _ var kind -> - [ toHie $ C (TyVarBind sc tsc) var - , toHie kind - ] - -instance ToHie (TScoped (LHsQTyVars GhcRn)) where - toHie (TS sc (HsQTvs implicits vars)) = concatM $ - [ bindingsOnly bindings - , toHie $ tvScopes sc NoScope vars - ] - where - varLoc = loc vars - bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits - -instance ToHie (LHsContext GhcRn) where - toHie (L span tys) = concatM $ - [ locOnly span - , toHie tys - ] - -instance ToHie (LConDeclField GhcRn) where - toHie (L span field) = concatM $ makeNode field span : case field of - ConDeclField _ fields typ _ -> - [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields - , toHie typ - ] - -instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where - toHie (From expr) = toHie expr - toHie (FromThen a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromTo a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromThenTo a b c) = concatM $ - [ toHie a - , toHie b - , toHie c - ] - -instance ToHie (LSpliceDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - SpliceDecl _ splice _ -> - [ toHie splice - ] - -instance ToHie (HsBracket a) where - toHie _ = pure [] - -instance ToHie PendingRnSplice where - toHie _ = pure [] - -instance ToHie PendingTcSplice where - toHie _ = pure [] - -instance ToHie (LBooleanFormula (Located Name)) where - toHie (L span form) = concatM $ makeNode form span : case form of - Var a -> - [ toHie $ C Use a - ] - And forms -> - [ toHie forms - ] - Or forms -> - [ toHie forms - ] - Parens f -> - [ toHie f - ] - -instance ToHie (Located HsIPName) where - toHie (L span e) = makeNode e span - -instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where - toHie (L span sp) = concatM $ makeNode sp span : case sp of - HsTypedSplice _ _ _ expr -> - [ toHie expr - ] - HsUntypedSplice _ _ _ expr -> - [ toHie expr - ] - HsQuasiQuote _ _ _ ispan _ -> - [ locOnly ispan - ] - HsSpliced _ _ _ -> - [] - XSplice x -> case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> noExtCon x - GhcRn -> noExtCon x -#endif - GhcTc -> case x of - HsSplicedT _ -> [] - -instance ToHie (LRoleAnnotDecl GhcRn) where - toHie (L span annot) = concatM $ makeNode annot span : case annot of - RoleAnnotDecl _ var roles -> - [ toHie $ C Use var - , concatMapM (locOnly . getLoc) roles - ] - -instance ToHie (LInstDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ClsInstD _ d -> - [ toHie $ L span d - ] - DataFamInstD _ d -> - [ toHie $ L span d - ] - TyFamInstD _ d -> - [ toHie $ L span d - ] - -instance ToHie (LClsInstDecl GhcRn) where - toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl - , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl - , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl - , toHie $ cid_tyfam_insts decl - , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl - , toHie $ cid_datafam_insts decl - , toHie $ cid_overlap_mode decl - ] - -instance ToHie (LDataFamInstDecl GhcRn) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (LTyFamInstDecl GhcRn) where - toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (Context a) - => ToHie (PatSynFieldContext (RecordPatSynField a)) where - toHie (PSC sp (RecordPatSynField a b)) = concatM $ - [ toHie $ C (RecField RecFieldDecl sp) a - , toHie $ C Use b - ] - -instance ToHie (LDerivDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DerivDecl _ typ strat overlap -> - [ toHie $ TS (ResolvedScopes []) typ - , toHie strat - , toHie overlap - ] - -instance ToHie (LFixitySig GhcRn) where - toHie (L span sig) = concatM $ makeNode sig span : case sig of - FixitySig _ vars _ -> - [ toHie $ map (C Use) vars - ] - -instance ToHie (LDefaultDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DefaultDecl _ typs -> - [ toHie typs - ] - -instance ToHie (LForeignDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> - [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name - , toHie $ TS (ResolvedScopes []) sig - , toHie fi - ] - ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> - [ toHie $ C Use name - , toHie $ TS (ResolvedScopes []) sig - , toHie fe - ] - -instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ - [ locOnly a - , locOnly b - , locOnly c - ] - -instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = concatM $ - [ locOnly a - , locOnly b - ] - -instance ToHie (LWarnDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warnings _ _ warnings -> - [ toHie warnings - ] - -instance ToHie (LWarnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warning _ vars _ -> - [ toHie $ map (C Use) vars - ] - -instance ToHie (LAnnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsAnnotation _ _ prov expr -> - [ toHie prov - , toHie expr - ] - -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where - toHie (ValueAnnProvenance a) = toHie $ C Use a - toHie (TypeAnnProvenance a) = toHie $ C Use a - toHie ModuleAnnProvenance = pure [] - -instance ToHie (LRuleDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsRules _ _ rules -> - [ toHie rules - ] - -instance ToHie (LRuleDecl GhcRn) where - toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope exprB - -instance ToHie (RScoped (LRuleBndr GhcRn)) where - toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - RuleBndr _ var -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - ] - RuleBndrSig _ var typ -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - , toHie $ TS (ResolvedScopes [sc]) typ - ] - -instance ToHie (LImportDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> - [ toHie $ IEC Import name - , toHie $ fmap (IEC ImportAs) as - , maybe (pure []) goIE hidden - ] - where - goIE (hiding, (L sp liens)) = concatM $ - [ locOnly sp - , toHie $ map (IEC c) liens - ] - where - c = if hiding then ImportHiding else Import - -instance ToHie (IEContext (LIE GhcRn)) where - toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of - IEVar _ n -> - [ toHie $ IEC c n - ] - IEThingAbs _ n -> - [ toHie $ IEC c n - ] - IEThingAll _ n -> - [ toHie $ IEC c n - ] - IEThingWith _ n _ ns flds -> - [ toHie $ IEC c n - , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds - ] - IEModuleContents _ n -> - [ toHie $ IEC c n - ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] - IEDocNamed _ _ -> [] - -instance ToHie (IEContext (LIEWrappedName Name)) where - toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of - IEName n -> - [ toHie $ C (IEThing c) n - ] - IEPattern p -> - [ toHie $ C (IEThing c) p - ] - IEType n -> - [ toHie $ C (IEThing c) n - ] - -instance ToHie (IEContext (Located (FieldLbl Name))) where - toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of - FieldLabel _ _ n -> - [ toHie $ C (IEThing c) $ L span n - ] From ead87d888105d8ed17688bc3b846315b90fdfacc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 19:19:05 +0800 Subject: [PATCH 58/86] hie-compat: Reexport the original version of HieBin --- hie-compat/src-ghc901/Compat/HieBin.hs | 367 +------------------------ 1 file changed, 2 insertions(+), 365 deletions(-) diff --git a/hie-compat/src-ghc901/Compat/HieBin.hs b/hie-compat/src-ghc901/Compat/HieBin.hs index 75989759db..254e1db6d3 100644 --- a/hie-compat/src-ghc901/Compat/HieBin.hs +++ b/hie-compat/src-ghc901/Compat/HieBin.hs @@ -1,371 +1,8 @@ {- Binary serialization for .hie files. -} -{- HLINT ignore -} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -module Compat.HieBin - ( readHieFile - , readHieFileWithVersion - , HieHeader - , writeHieFile - , HieName(..) - , toHieName - , HieFileResult(..) - , hieMagic - , hieNameOcc - , NameCacheUpdater(..) - ) +module Compat.HieBin ( module GHC.Iface.Ext.Binary) where -import GHC.Settings.Utils ( maybeRead ) -import GHC.Settings.Config ( cProjectVersion ) --- import GHC.Prelude -import GHC.Utils.Binary -import GHC.Iface.Binary ( getDictFastString ) -import GHC.Data.FastMutInt -import GHC.Data.FastString ( FastString ) -import GHC.Types.Name -import GHC.Types.Name.Cache -import GHC.Utils.Outputable -import GHC.Builtin.Utils -import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique.Supply ( takeUniqFromSupply ) -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Iface.Env (NameCacheUpdater(..)) --- 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 GHC.Iface.Ext.Types - -data HieSymbolTable = HieSymbolTable - { hie_symtab_next :: !FastMutInt - , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) - } - -data HieDictionary = HieDictionary - { hie_dict_next :: !FastMutInt -- The next index to use - , hie_dict_map :: !(IORef (UniqFM FastString (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 initial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) - 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_Directly 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_Directly out unique (j, f) - -putSymbolTable :: BinHandle -> Int -> UniqFM Name (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 - -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 "GHC.Iface.Ext.Binary.getHieName: invalid tag" +import GHC.Iface.Ext.Binary From d97ba29595a999ecd8d75f952234a508d7b5ab32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 19:46:23 +0800 Subject: [PATCH 59/86] Don't include broken "allow-newer"s --- cabal.project | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/cabal.project b/cabal.project index b528b1cf87..7eef187c73 100644 --- a/cabal.project +++ b/cabal.project @@ -103,17 +103,17 @@ constraints: optparse-applicative < 0.16 allow-newer: - -- Broken on ghc9, but let's pretend it's not so we can build the other things - brittany:base, - brittany:ghc, - brittany:ghc-boot-th, - butcher:base, - fourmolu:ghc-lib-parser, - ormolu:ghc-lib-parser, - stylish-haskell:ghc-lib-parser, - stylish-haskell:Cabal, - multistate:base, - ghc-source-gen:ghc, + -- -- Broken on ghc9, but let's pretend it's not so we can build the other things + -- brittany:base, + -- brittany:ghc, + -- brittany:ghc-boot-th, + -- butcher:base, + -- fourmolu:ghc-lib-parser, + -- ormolu:ghc-lib-parser, + -- stylish-haskell:ghc-lib-parser, + -- stylish-haskell:Cabal, + -- multistate:base, + -- ghc-source-gen:ghc, active:base, assoc:base, From 88b4e8aaf0cbe9b3d4531ca5e6f2c83db92af0c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 20:02:34 +0800 Subject: [PATCH 60/86] FIx stack build for ghc9 --- plugins/hls-hlint-plugin/hls-hlint-plugin.cabal | 2 +- stack-9.0.1.yaml | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index e3c86677f9..bbdbae2c78 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -49,7 +49,7 @@ library , ghc-exactprint >=0.6.3.4 , ghcide >=1.2 && <1.4 , hashable - , hlint ^>=3.2 + , hlint , hls-plugin-api ^>=1.1 , hslogger , lens diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 399e0f7005..f8b50148a1 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -20,6 +20,11 @@ packages: # - ./plugins/hls-tactics-plugin # - ./plugins/hls-brittany-plugin # - ./plugins/hls-stylish-haskell-plugin + # - ./plugins/hls-floskell-plugin + # - ./plugins/hls-fourmolu-plugin + - ./plugins/hls-pragmas-plugin + - ./plugins/hls-module-name-plugin + # - ./plugins/hls-ormolu-plugin ghc-options: "$everything": -haddock From 3cedea01f0295bc3b0ab7a8ca28c988655b31231 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 20:12:51 +0800 Subject: [PATCH 61/86] Fix warning from imperfect merge commit --- test/functional/Format.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 93542a60af..4620f4fdd8 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -14,7 +14,6 @@ import qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command import Test.Hls.Flags (requiresFloskellPlugin, - requiresFourmoluPlugin, requiresOrmoluPlugin) tests :: TestTree From 660de9fcdf8afb3d7a9f65448d6d0f70b0703e24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 19:05:08 +0800 Subject: [PATCH 62/86] Don't needlessly duplicate code from ghc --- hie-compat/src-ghc901/Compat/HieAst.hs | 2014 +----------------------- 1 file changed, 9 insertions(+), 2005 deletions(-) diff --git a/hie-compat/src-ghc901/Compat/HieAst.hs b/hie-compat/src-ghc901/Compat/HieAst.hs index 0b314f3d22..26f315caef 100644 --- a/hie-compat/src-ghc901/Compat/HieAst.hs +++ b/hie-compat/src-ghc901/Compat/HieAst.hs @@ -4,279 +4,26 @@ Forked from GHC v9.0.1 to work around the readFile side effect in mkHiefile Main functions for .hie file generation -} {- HLINT ignore -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Compat.HieAst ( mkHieFile, enrichHie ) where -import GHC.Utils.Outputable(ppr) +import GHC.Data.Maybe (expectJust) +import GHC.Driver.Types +import GHC.Hs +import GHC.Tc.Types (TcGblEnv) +import GHC.Types.Avail (Avails) +import GHC.Unit.Module (ml_hs_file) -import GHC.Prelude +import GHC.Iface.Ext.Ast (enrichHie, mkHieFileWithSource) +import GHC.Iface.Ext.Types -import GHC.Types.Avail ( Avails ) -import GHC.Data.Bag ( Bag, bagToList ) -import GHC.Types.Basic -import GHC.Data.BooleanFormula -import GHC.Core.Class ( FunDep, className, classSCSelIds ) -import GHC.Core.Utils ( exprType ) -import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) -import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) -import GHC.Core.FVs -import GHC.Core.DataCon ( dataConNonlinearType ) -import GHC.HsToCore ( deSugarExpr ) -import GHC.Types.FieldLabel -import GHC.Hs -import GHC.Driver.Types -import GHC.Unit.Module ( ModuleName, ml_hs_file ) -import GHC.Utils.Monad ( concatMapM, liftIO ) -import GHC.Types.Id ( isDataConId_maybe ) -import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) -import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import GHC.Types.SrcLoc -import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType ) -import GHC.Core.Type ( mkVisFunTys, Type ) -import GHC.Core.Predicate -import GHC.Core.InstEnv -import GHC.Builtin.Types ( mkListTy, mkSumTy ) -import GHC.Tc.Types -import GHC.Tc.Types.Evidence -import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) -import GHC.Types.Var.Env -import GHC.Types.Unique -import GHC.Iface.Make ( mkIfaceExports ) -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Data.FastString +import qualified Data.ByteString as BS -import GHC.Iface.Ext.Types -import GHC.Iface.Ext.Utils -import qualified Data.Array as A -import qualified Data.ByteString as BS -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Data ( Data, Typeable ) -import Data.List ( foldl1' ) -import Control.Monad ( forM_ ) -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class ( lift ) - -{- Note [Updating HieAst for changes in the GHC AST] - -When updating the code in this file for changes in the GHC AST, you -need to pay attention to the following things: - -1) Symbols (Names/Vars/Modules) in the following categories: - - a) Symbols that appear in the source file that directly correspond to - something the user typed - b) Symbols that don't appear in the source, but should be in some sense - "visible" to a user, particularly via IDE tooling or the like. This - includes things like the names introduced by RecordWildcards (We record - all the names introduced by a (..) in HIE files), and will include implicit - parameters and evidence variables after one of my pending MRs lands. - -2) Subtrees that may contain such symbols, or correspond to a SrcSpan in - the file. This includes all `Located` things - -For 1), you need to call `toHie` for one of the following instances - -instance ToHie (Context (Located Name)) where ... -instance ToHie (Context (Located Var)) where ... -instance ToHie (IEContext (Located ModuleName)) where ... - -`Context` is a data type that looks like: - -data Context a = C ContextInfo a -- Used for names and bindings - -`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like - -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 - ... - -It is used to annotate symbols in the .hie files with some extra information on -the context in which they occur and should be fairly self explanatory. You need -to select one that looks appropriate for the symbol usage. In very rare cases, -you might need to extend this sum type if none of the cases seem appropriate. - -So, given a `Located Name` that is just being "used", and not defined at a -particular location, you would do the following: - - toHie $ C Use located_name - -If you select one that corresponds to a binding site, you will need to -provide a `Scope` and a `Span` for your binding. Both of these are basically -`SrcSpans`. - -The `SrcSpan` in the `Scope` is supposed to span over the part of the source -where the symbol can be legally allowed to occur. For more details on how to -calculate this, see Note [Capturing Scopes and other non local information] -in GHC.Iface.Ext.Ast. - -The binding `Span` is supposed to be the span of the entire binding for -the name. - -For a function definition `foo`: - -foo x = x + y - where y = x^2 - -The binding `Span` is the span of the entire function definition from `foo x` -to `x^2`. For a class definition, this is the span of the entire class, and -so on. If this isn't well defined for your bit of syntax (like a variable -bound by a lambda), then you can just supply a `Nothing` - -There is a test that checks that all symbols in the resulting HIE file -occur inside their stated `Scope`. This can be turned on by passing the --fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the -.hie file. - -You may also want to provide a test in testsuite/test/hiefile that includes -a file containing your new construction, and tests that the calculated scope -is valid (by using -fvalidate-ide-info) - -For subtrees in the AST that may contain symbols, the procedure is fairly -straightforward. If you are extending the GHC AST, you will need to provide a -`ToHie` instance for any new types you may have introduced in the AST. - -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): - - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - ... - HsApp _ a b -> - [ toHie a - , toHie b - ] - -If your subtree is `Located` or has a `SrcSpan` available, the output list -should contain a HieAst `Node` corresponding to the subtree. You can use -either `makeNode` or `getTypeNode` for this purpose, depending on whether it -makes sense to assign a `Type` to the subtree. After this, you just need -to concatenate the result of calling `toHie` on all subexpressions and -appropriately annotated symbols contained in the subtree. - -The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed -to work for both the renamed and typechecked source. `getTypeNode` is from -the `HasType` class defined in this file, and it has different instances -for `GhcTc` and `GhcRn` that allow it to access the type of the expression -when given a typechecked AST: - -class Data a => HasType a where - getTypeNode :: a -> HieM [HieAST Type] -instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = ... -- Actually get the type for this expression -instance HasType (LHsExpr GhcRn) where - getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type - -If your subtree doesn't have a span available, you can omit the `makeNode` -call and just recurse directly in to the subexpressions. - --} - --- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] , Maybe LHsDocString ) -type TypecheckedSource = LHsBinds GhcTc - - -{- Note [Name Remapping] -The Typechecker introduces new names for mono names in AbsBinds. -We don't care about the distinction between mono and poly bindings, -so we replace all occurrences of the mono name with the poly name. --} -type VarMap a = DVarEnv (Var,a) -data HieState = HieState - { name_remapping :: NameEnv Id - , unlocated_ev_binds :: VarMap (S.Set ContextInfo) - -- These contain evidence bindings that we don't have a location for - -- These are placed at the top level Node in the HieAST after everything - -- else has been generated - -- This includes things like top level evidence bindings. - } - -addUnlocatedEvBind :: Var -> ContextInfo -> HieM () -addUnlocatedEvBind var ci = do - let go (a,b) (_,c) = (a,S.union b c) - lift $ modify' $ \s -> - s { unlocated_ev_binds = - extendDVarEnv_C go (unlocated_ev_binds s) - var (var,S.singleton ci) - } - -getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type]) -getUnlocatedEvBinds file = do - binds <- lift $ gets unlocated_ev_binds - org <- ask - let elts = dVarEnvElts binds - - mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci) - - go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of - RealSrcSpan spn _ - | srcSpanFile spn == file -> - let node = Node (mkSourcedNodeInfo org ni) spn [] - ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] - in (xs,node:ys) - _ -> (mkNodeInfo e : xs,ys) - - (nis,asts) = foldr go ([],[]) elts - - pure $ (M.fromList nis, asts) - -initState :: HieState -initState = HieState emptyNameEnv emptyDVarEnv - -class ModifyState a where -- See Note [Name Remapping] - addSubstitution :: a -> a -> HieState -> HieState - -instance ModifyState Name where - addSubstitution _ _ hs = hs - -instance ModifyState Id where - addSubstitution mono poly hs = - hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} - -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState -modifyState = foldr go id - where - go ABE{abe_poly=poly,abe_mono=mono} f - = addSubstitution mono poly . f - go _ f = f - -type HieM = ReaderT NodeOrigin (StateT HieState Hsc) -- | Construct an 'HieFile' from the outputs of the typechecker. mkHieFile :: ModSummary @@ -286,1746 +33,3 @@ mkHieFile :: ModSummary mkHieFile ms ts rs src = do let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) mkHieFileWithSource src_file src ms ts rs - --- | Construct an 'HieFile' from the outputs of the typechecker but don't --- read the source file again from disk. -mkHieFileWithSource :: FilePath - -> BS.ByteString - -> ModSummary - -> TcGblEnv - -> RenamedSource -> Hsc HieFile -mkHieFileWithSource src_file src ms ts rs = do - let tc_binds = tcg_binds ts - top_ev_binds = tcg_ev_binds ts - insts = tcg_insts ts - tcs = tcg_tcs ts - (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs - return $ HieFile - { hie_hs_file = src_file - , hie_module = ms_mod ms - , hie_types = arr - , hie_asts = asts' - -- mkIfaceExports sorts the AvailInfos for stability - , hie_exports = mkIfaceExports (tcg_exports ts) - , hie_hs_src = src - } - -getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) -getCompressedAsts ts rs top_ev_binds insts tcs = do - asts <- enrichHie ts rs top_ev_binds insts tcs - return $ compressTypes asts - -enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] - -> Hsc (HieASTs Type) -enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = - flip evalStateT initState $ flip runReaderT SourceInfo $ do - tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts - rasts <- processGrp hsGrp - imps <- toHie $ filter (not . ideclImplicit . unLoc) imports - exps <- toHie $ fmap (map $ IEC Export . fst) exports - -- Add Instance bindings - forM_ insts $ \i -> - addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) - -- Add class parent bindings - forM_ tcs $ \tc -> - case tyConClass_maybe tc of - Nothing -> pure () - Just c -> forM_ (classSCSelIds c) $ \v -> - addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) - let spanFile file children = case children of - [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) - _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) - (realSrcSpanEnd $ nodeSpan $ last children) - - flat_asts = concat - [ tasts - , rasts - , imps - , exps - ] - - modulify file xs' = do - - top_ev_asts <- - toHie $ EvBindContext ModuleScope Nothing - $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) - $ EvBinds ev_bs - - (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file - - let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts - span = spanFile file xs - - moduleInfo = SourcedNodeInfo - $ M.singleton SourceInfo - $ (simpleNodeInfo "Module" "Module") - {nodeIdentifiers = uloc_evs} - - moduleNode = Node moduleInfo span [] - - case mergeSortAsts $ moduleNode : xs of - [x] -> return x - xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs) - - asts' <- sequence - $ M.mapWithKey modulify - $ M.fromListWith (++) - $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts - - let asts = HieASTs $ resolveTyVarScopes asts' - return asts - where - processGrp grp = concatM - [ toHie $ fmap (RS ModuleScope ) hs_valds grp - , toHie $ hs_splcds grp - , toHie $ hs_tyclds grp - , toHie $ hs_derivds grp - , toHie $ hs_fixds grp - , toHie $ hs_defds grp - , toHie $ hs_fords grp - , toHie $ hs_warnds grp - , toHie $ hs_annds grp - , toHie $ hs_ruleds grp - ] - -getRealSpan :: SrcSpan -> Maybe Span -getRealSpan (RealSrcSpan sp _) = Just sp -getRealSpan _ = Nothing - -grhss_span :: GRHSs p body -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) -grhss_span (XGRHSs _) = panic "XGRHS has no span" - -bindingsOnly :: [Context Name] -> HieM [HieAST a] -bindingsOnly [] = pure [] -bindingsOnly (C c n : xs) = do - org <- ask - rest <- bindingsOnly xs - pure $ case nameSrcSpan n of - RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest - where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) - info = mempty{identInfo = S.singleton c} - _ -> rest - -concatM :: Monad m => [m [a]] -> m [a] -concatM xs = concat <$> sequence xs - -{- Note [Capturing Scopes and other non local information] -toHie is a local transformation, but scopes of bindings cannot be known locally, -hence we have to push the relevant info down into the binding nodes. -We use the following types (*Context and *Scoped) to wrap things and -carry the required info -(Maybe Span) always carries the span of the entire binding, including rhs --} -data Context a = C ContextInfo a -- Used for names and bindings - -data RContext a = RC RecFieldContext a -data RFContext a = RFC RecFieldContext (Maybe Span) a --- ^ context for record fields - -data IEContext a = IEC IEType a --- ^ context for imports/exports - -data BindContext a = BC BindType Scope a --- ^ context for imports/exports - -data PatSynFieldContext a = PSC (Maybe Span) a --- ^ context for pattern synonym fields. - -data SigContext a = SC SigInfo a --- ^ context for type signatures - -data SigInfo = SI SigType (Maybe Span) - -data SigType = BindSig | ClassSig | InstSig - -data EvBindContext a = EvBindContext Scope (Maybe Span) a - -data RScoped a = RS Scope a --- ^ Scope spans over everything to the right of a, (mostly) not --- including a itself --- (Includes a in a few special cases like recursive do bindings) or --- let/where bindings - --- | Pattern scope -data PScoped a = PS (Maybe Span) - Scope -- ^ use site of the pattern - Scope -- ^ pattern to the right of a, not including a - a - deriving (Typeable, Data) -- Pattern Scope - -{- Note [TyVar Scopes] -Due to -XScopedTypeVariables, type variables can be in scope quite far from -their original binding. We resolve the scope of these type variables -in a separate pass --} -data TScoped a = TS TyVarScope a -- TyVarScope - -data TVScoped a = TVS TyVarScope Scope a -- TyVarScope --- ^ First scope remains constant --- Second scope is used to build up the scope of a tyvar over --- things to its right, ala RScoped - --- | Each element scopes over the elements to the right -listScopes :: Scope -> [Located a] -> [RScoped (Located a)] -listScopes _ [] = [] -listScopes rhsScope [pat] = [RS rhsScope pat] -listScopes rhsScope (pat : pats) = RS sc pat : pats' - where - pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLoc p - --- | 'listScopes' specialised to 'PScoped' things -patScopes - :: Maybe Span - -> Scope - -> Scope - -> [LPat (GhcPass p)] - -> [PScoped (LPat (GhcPass p))] -patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc a) $ - listScopes patScope xs - --- | 'listScopes' specialised to 'TVScoped' things -tvScopes - :: TyVarScope - -> Scope - -> [LHsTyVarBndr flag a] - -> [TVScoped (LHsTyVarBndr flag a)] -tvScopes tvScope rhsScope xs = - map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs - -{- Note [Scoping Rules for SigPat] -Explicitly quantified variables in pattern type signatures are not -brought into scope in the rhs, but implicitly quantified variables -are (HsWC and HsIB). -This is unlike other signatures, where explicitly quantified variables -are brought into the RHS Scope -For example -foo :: forall a. ...; -foo = ... -- a is in scope here - -bar (x :: forall a. a -> a) = ... -- a is not in scope here --- ^ a is in scope here (pattern body) - -bax (x :: a) = ... -- a is in scope here - -This case in handled in the instance for HsPatSigType --} - -class HasLoc a where - -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can - -- know what their implicit bindings are scoping over - loc :: a -> SrcSpan - -instance HasLoc thing => HasLoc (TScoped thing) where - loc (TS _ a) = loc a - -instance HasLoc thing => HasLoc (PScoped thing) where - loc (PS _ _ _ a) = loc a - -instance HasLoc (LHsQTyVars GhcRn) where - loc (HsQTvs _ vs) = loc vs - -instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where - loc (HsIB _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where - loc (HsWC _ a) = loc a - loc _ = noSrcSpan - -instance HasLoc (Located a) where - loc (L l _) = l - -instance HasLoc a => HasLoc [a] where - loc [] = noSrcSpan - loc xs = foldl1' combineSrcSpans $ map loc xs - -instance HasLoc a => HasLoc (FamEqn s a) where - loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] - loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans - [loc a, loc tvs, loc b, loc c] - loc _ = noSrcSpan -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where - loc (HsValArg tm) = loc tm - loc (HsTypeArg _ ty) = loc ty - loc (HsArgPar sp) = sp - -instance HasLoc (HsDataDefn GhcRn) where - loc def@(HsDataDefn{}) = loc $ dd_cons def - -- Only used for data family instances, so we only need rhs - -- Most probably the rest will be unhelpful anyway - -{- Note [Real DataCon Name] -The typechecker substitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - --- | The main worker class --- See Note [Updating HieAst for changes in the GHC AST] for more information --- on how to add/modify instances for this. -class ToHie a where - toHie :: a -> HieM [HieAST Type] - --- | Used to collect type info -class HasType a where - getTypeNode :: a -> HieM [HieAST Type] - -instance (ToHie a) => ToHie [a] where - toHie = concatMapM toHie - -instance (ToHie a) => ToHie (Bag a) where - toHie = toHie . bagToList - -instance (ToHie a) => ToHie (Maybe a) where - toHie = maybe (pure []) toHie - -instance ToHie (IEContext (Located ModuleName)) where - toHie (IEC c (L (RealSrcSpan span _) mname)) = do - org <- ask - pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []] - where details = mempty{identInfo = S.singleton (IEThing c)} - idents = M.singleton (Left mname) details - toHie _ = pure [] - -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | varUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - ty = case isDataConId_maybe name' of - Nothing -> varType name' - Just dc -> dataConNonlinearType dc - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right $ varName name) - (IdentifierDetails (Just ty) - (S.singleton context))) - span - []] - C (EvidenceVarBind i _ sp) (L _ name) -> do - addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) - pure [] - _ -> pure [] - -instance ToHie (Context (Located Name)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | nameUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m name' of - Just var -> varName var - Nothing -> name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right name) - (IdentifierDetails Nothing - (S.singleton context))) - span - []] - _ -> pure [] - -evVarsOfTermList :: EvTerm -> [EvId] -evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e -evVarsOfTermList (EvTypeable _ ev) = - case ev of - EvTypeableTyCon _ e -> concatMap evVarsOfTermList e - EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] - EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] - EvTypeableTyLit e -> evVarsOfTermList e -evVarsOfTermList (EvFun{}) = [] - -instance ToHie (EvBindContext (Located TcEvBinds)) where - toHie (EvBindContext sc sp (L span (EvBinds bs))) - = concatMapM go $ bagToList bs - where - go evbind = do - let evDeps = evVarsOfTermList $ eb_rhs evbind - depNames = EvBindDeps $ map varName evDeps - concatM $ - [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) - (L span $ eb_lhs evbind)) - , toHie $ map (C EvidenceVarUse . L span) $ evDeps - ] - toHie _ = pure [] - -instance ToHie (Located HsWrapper) where - toHie (L osp wrap) - = case wrap of - (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) - (WpCompose a b) -> concatM $ - [toHie (L osp a), toHie (L osp b)] - (WpFun a b _ _) -> concatM $ - [toHie (L osp a), toHie (L osp b)] - (WpEvLam a) -> - toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) - $ L osp a - (WpEvApp a) -> - concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a - _ -> pure [] - -instance HiePass p => HasType (LHsBind (GhcPass p)) where - getTypeNode (L spn bind) = - case hiePass @p of - HieRn -> makeNode bind spn - HieTc -> case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn - -instance HiePass p => HasType (Located (Pat (GhcPass p))) where - getTypeNode (L spn pat) = - case hiePass @p of - HieRn -> makeNode pat spn - HieTc -> makeTypeNode pat spn (hsPatType pat) - --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. --- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 -instance HiePass p => HasType (LHsExpr (GhcPass p)) where - getTypeNode e@(L spn e') = - case hiePass @p of - HieRn -> makeNode e' spn - HieTc -> - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) - - HsConLikeOut _ (RealDataCon con) -> Just (dataConNonlinearType con) - - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty - - _ -> Nothing - - in - case tyOpt of - Just t -> makeTypeNode e' spn t - Nothing - | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn - - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkVisFunTys args res - - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr GhcTc -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - XExpr (WrapExpr {}) -> False - _ -> True - -data HiePassEv p where - HieRn :: HiePassEv 'Renamed - HieTc :: HiePassEv 'Typechecked - -class ( IsPass p - , HiePass (NoGhcTcPass p) - , ModifyState (IdGhcP p) - , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) - , Data (HsExpr (GhcPass p)) - , Data (HsCmd (GhcPass p)) - , Data (AmbiguousFieldOcc (GhcPass p)) - , Data (HsCmdTop (GhcPass p)) - , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) - , Data (HsSplice (GhcPass p)) - , Data (HsLocalBinds (GhcPass p)) - , Data (FieldOcc (GhcPass p)) - , Data (HsTupArg (GhcPass p)) - , Data (IPBind (GhcPass p)) - , ToHie (Context (Located (IdGhcP p))) - , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) - , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) - , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) - , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) - , HasRealDataConName (GhcPass p) - ) - => HiePass p where - hiePass :: HiePassEv p - -instance HiePass 'Renamed where - hiePass = HieRn -instance HiePass 'Typechecked where - hiePass = HieTc - -instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where - toHie (BC context scope b@(L span bind)) = - concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> - [ toHie $ C (ValBind context scope $ getRealSpan span) name - , toHie matches - , case hiePass @p of - HieTc -> toHie $ L span wrap - _ -> pure [] - ] - PatBind{pat_lhs = lhs, pat_rhs = rhs} -> - [ toHie $ PS (getRealSpan span) scope NoScope lhs - , toHie rhs - ] - VarBind{var_rhs = expr} -> - [ toHie expr - ] - AbsBinds{ abs_exports = xs, abs_binds = binds - , abs_ev_binds = ev_binds - , abs_ev_vars = ev_vars } -> - [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] - (toHie $ fmap (BC context scope) binds) - , toHie $ map (L span . abe_wrap) xs - , toHie $ - map (EvBindContext (mkScope span) (getRealSpan span) - . L span) ev_binds - , toHie $ - map (C (EvidenceVarBind EvSigBind - (mkScope span) - (getRealSpan span)) - . L span) ev_vars - ] - PatSynBind _ psb -> - [ toHie $ L span psb -- PatSynBinds only occur at the top level - ] - -instance ( HiePass p - , ToHie (Located body) - , Data body - ) => ToHie (MatchGroup (GhcPass p) (Located body)) where - toHie mg = case mg of - MG{ mg_alts = (L span alts) , mg_origin = origin} -> - local (setOrigin origin) $ concatM - [ locOnly span - , toHie alts - ] - -setOrigin :: Origin -> NodeOrigin -> NodeOrigin -setOrigin FromSource _ = SourceInfo -setOrigin Generated _ = GeneratedInfo - -instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where - toHie (L sp psb) = concatM $ case psb of - PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> - [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var - , toHie $ toBind dets - , toHie $ PS Nothing lhsScope patScope pat - , toHie dir - ] - where - lhsScope = combineScopes varScope detScope - varScope = mkLScope var - patScope = mkScope $ getLoc pat - detScope = case dets of - (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args - (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) - (RecCon r) -> foldr go NoScope r - go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope a) (mkLScope b) - detSpan = case detScope of - LocalScope a -> Just a - _ -> Nothing - toBind (PrefixCon args) = PrefixCon $ map (C Use) args - toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) - toBind (RecCon r) = RecCon $ map (PSC detSpan) r - -instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where - toHie dir = case dir of - ExplicitBidirectional mg -> toHie mg - _ -> pure [] - -instance ( HiePass p - , Data body - , ToHie (Located body) - ) => ToHie (LMatch (GhcPass p) (Located body)) where - toHie (L span m ) = concatM $ node : case m of - Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> - [ toHie mctx - , let rhsScope = mkScope $ grhss_span grhss - in toHie $ patScopes Nothing rhsScope NoScope pats - , toHie grhss - ] - where - node = case hiePass @p of - HieTc -> makeNode m span - HieRn -> makeNode m span - -instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where - toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name - toHie (StmtCtxt a) = toHie a - toHie _ = pure [] - -instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where - toHie (PatGuard a) = toHie a - toHie (ParStmtCtxt a) = toHie a - toHie (TransStmtCtxt a) = toHie a - toHie _ = pure [] - -instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(L ospan opat)) = - concatM $ getTypeNode lpat : case opat of - WildPat _ -> - [] - VarPat _ lname -> - [ toHie $ C (PatternBind scope pscope rsp) lname - ] - LazyPat _ p -> - [ toHie $ PS rsp scope pscope p - ] - AsPat _ lname pat -> - [ toHie $ C (PatternBind scope - (combineScopes (mkLScope pat) pscope) - rsp) - lname - , toHie $ PS rsp scope pscope pat - ] - ParPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - BangPat _ pat -> - [ toHie $ PS rsp scope pscope pat - ] - ListPat _ pats -> - [ toHie $ patScopes rsp scope pscope pats - ] - TuplePat _ pats _ -> - [ toHie $ patScopes rsp scope pscope pats - ] - SumPat _ pat _ _ -> - [ toHie $ PS rsp scope pscope pat - ] - ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} -> - case hiePass @p of - HieTc -> - [ toHie $ C Use $ fmap conLikeName con - , toHie $ contextify dets - , let ev_binds = cpt_binds ext - ev_vars = cpt_dicts ext - wrap = cpt_wrap ext - evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope - in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds - , toHie $ L ospan wrap - , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) - . L ospan) ev_vars - ] - ] - HieRn -> - [ toHie $ C Use con - , toHie $ contextify dets - ] - ViewPat _ expr pat -> - [ toHie expr - , toHie $ PS rsp scope pscope pat - ] - SplicePat _ sp -> - [ toHie $ L ospan sp - ] - LitPat _ _ -> - [] - NPat _ _ _ _ -> - [] - NPlusKPat _ n _ _ _ _ -> - [ toHie $ C (PatternBind scope pscope rsp) n - ] - SigPat _ pat sig -> - [ toHie $ PS rsp scope pscope pat - , case hiePass @p of - HieTc -> - let cscope = mkLScope pat in - toHie $ TS (ResolvedScopes [cscope, scope, pscope]) - sig - HieRn -> pure [] - ] - XPat e -> - case hiePass @p of - HieTc -> - let CoPat wrap pat _ = e - in [ toHie $ L ospan wrap - , toHie $ PS rsp scope pscope $ (L ospan pat) - ] -#if __GLASGOW_HASKELL__ < 811 - HieRn -> [] -#endif - where - contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) - -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) - contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args - contextify (InfixCon a b) = InfixCon a' b' - where [a', b'] = patScopes rsp scope pscope [a,b] - contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r - contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a - where - go (RS fscope (L spn (HsRecField lbl pat pun))) = - L spn $ HsRecField lbl (PS rsp scope fscope pat) pun - scoped_fds = listScopes pscope fds - - -instance ToHie (TScoped (HsPatSigType GhcRn)) where - toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) - , toHie body - ] - -- See Note [Scoping Rules for SigPat] - -instance ( ToHie (Located body) - , HiePass p - , Data body - ) => ToHie (GRHSs (GhcPass p) (Located body)) where - toHie grhs = concatM $ case grhs of - GRHSs _ grhss binds -> - [ toHie grhss - , toHie $ RS (mkScope $ grhss_span grhs) binds - ] - -instance ( ToHie (Located body) - , HiePass a - , Data body - ) => ToHie (LGRHS (GhcPass a) (Located body)) where - toHie (L span g) = concatM $ node : case g of - GRHS _ guards body -> - [ toHie $ listScopes (mkLScope body) guards - , toHie body - ] - where - node = case hiePass @a of - HieRn -> makeNode g span - HieTc -> makeNode g span - -instance HiePass p => ToHie (LHsExpr (GhcPass p)) where - toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of - HsVar _ (L _ var) -> - [ toHie $ C Use (L mspan var) - -- Patch up var location since typechecker removes it - ] - HsUnboundVar _ _ -> - [] - HsConLikeOut _ con -> - [ toHie $ C Use $ L mspan $ conLikeName con - ] - HsRecFld _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) - ] - HsOverLabel _ _ _ -> [] - HsIPVar _ _ -> [] - HsOverLit _ _ -> [] - HsLit _ _ -> [] - HsLam _ mg -> - [ toHie mg - ] - HsLamCase _ mg -> - [ toHie mg - ] - HsApp _ a b -> - [ toHie a - , toHie b - ] - HsAppType _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes []) sig - ] - OpApp _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - NegApp _ a _ -> - [ toHie a - ] - HsPar _ a -> - [ toHie a - ] - SectionL _ a b -> - [ toHie a - , toHie b - ] - SectionR _ a b -> - [ toHie a - , toHie b - ] - ExplicitTuple _ args _ -> - [ toHie args - ] - ExplicitSum _ _ _ expr -> - [ toHie expr - ] - HsCase _ expr matches -> - [ toHie expr - , toHie matches - ] - HsIf _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsMultiIf _ grhss -> - [ toHie grhss - ] - HsLet _ binds expr -> - [ toHie $ RS (mkLScope expr) binds - , toHie expr - ] - HsDo _ _ (L ispan stmts) -> - [ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - ExplicitList _ _ exprs -> - [ toHie exprs - ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) - -- See Note [Real DataCon Name] - , toHie $ RC RecFieldAssign $ binds - ] - RecordUpd {rupd_expr = expr, rupd_flds = upds}-> - [ toHie expr - , toHie $ map (RC RecFieldAssign) upds - ] - ExprWithTySig _ expr sig -> - [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScope expr]) sig - ] - ArithSeq _ _ info -> - [ toHie info - ] - HsPragE _ _ expr -> - [ toHie expr - ] - HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat - , toHie cmdtop - ] - HsStatic _ expr -> - [ toHie expr - ] - HsTick _ _ expr -> - [ toHie expr - ] - HsBinTick _ _ _ expr -> - [ toHie expr - ] - HsBracket _ b -> - [ toHie b - ] - HsRnBracketOut _ b p -> - [ toHie b - , toHie p - ] - HsTcBracketOut _ _wrap b p -> - [ toHie b - , toHie p - ] - HsSpliceE _ x -> - [ toHie $ L mspan x - ] - XExpr x - | GhcTc <- ghcPass @p - , WrapExpr (HsWrap w a) <- x - -> [ toHie $ L mspan a - , toHie (L mspan w) - ] - | GhcTc <- ghcPass @p - , ExpansionExpr (HsExpanded _ b) <- x - -> [ toHie (L mspan b) - ] - | otherwise -> [] - -instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where - toHie (L span arg) = concatM $ makeNode arg span : case arg of - Present _ expr -> - [ toHie expr - ] - Missing _ -> [] - -instance ( ToHie (Located body) - , Data body - , HiePass p - ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where - toHie (RS scope (L span stmt)) = concatM $ node : case stmt of - LastStmt _ body _ _ -> - [ toHie body - ] - BindStmt _ pat body -> - [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat - , toHie body - ] - ApplicativeStmt _ stmts _ -> - [ concatMapM (toHie . RS scope . snd) stmts - ] - BodyStmt _ body _ _ -> - [ toHie body - ] - LetStmt _ binds -> - [ toHie $ RS scope binds - ] - ParStmt _ parstmts _ _ -> - [ concatMapM (\(ParStmtBlock _ stmts _ _) -> - toHie $ listScopes NoScope stmts) - parstmts - ] - TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> - [ toHie $ listScopes scope stmts - , toHie using - , toHie by - ] - RecStmt {recS_stmts = stmts} -> - [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts - ] - where - node = case hiePass @p of - HieTc -> makeNode stmt span - HieRn -> makeNode stmt span - -instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where - toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of - EmptyLocalBinds _ -> [] - HsIPBinds _ ipbinds -> case ipbinds of - IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in - [ case hiePass @p of - HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds - HieRn -> pure [] - , toHie $ map (RS sc) xs - ] - HsValBinds _ valBinds -> - [ toHie $ RS (combineScopes scope $ mkScope sp) - valBinds - ] - -instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where - toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of - IPBind _ (Left _) expr -> [toHie expr] - IPBind _ (Right v) expr -> - [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) - $ L sp v - , toHie expr - ] - -instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where - toHie (RS sc v) = concatM $ case v of - ValBinds _ binds sigs -> - [ toHie $ fmap (BC RegularBind sc) binds - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - XValBindsLR x -> [ toHie $ RS sc x ] - -instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where - toHie (RS sc (NValBinds binds sigs)) = concatM $ - [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) - , toHie $ fmap (SC (SI BindSig Nothing)) sigs - ] - -instance ( ToHie arg , HasLoc arg , Data arg - , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where - toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields - -instance ( ToHie (RFContext (Located label)) - , ToHie arg , HasLoc arg , Data arg - , Data label - ) => ToHie (RContext (LHsRecField' label arg)) where - toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of - HsRecField label expr _ -> - [ toHie $ RFC c (getRealSpan $ loc expr) label - , toHie expr - ] - -instance ToHie (RFContext (LFieldOcc GhcRn)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc name _ -> - [ toHie $ C (RecField c rhs) (L nspan name) - ] - -instance ToHie (RFContext (LFieldOcc GhcTc)) where - toHie (RFC c rhs (L nspan f)) = concatM $ case f of - FieldOcc var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous name _ -> - [ toHie $ C (RecField c rhs) $ L nspan name - ] - Ambiguous _name _ -> - [ ] - -instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where - toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of - Unambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - Ambiguous var _ -> - [ toHie $ C (RecField c rhs) (L nspan var) - ] - -instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where - toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM - [ toHie $ PS Nothing sc NoScope pat - , toHie expr - ] - toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM - [ toHie $ listScopes NoScope stmts - , toHie $ PS Nothing sc NoScope pat - ] - -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where - toHie (PrefixCon args) = toHie args - toHie (RecCon rec) = toHie rec - toHie (InfixCon a b) = concatM [ toHie a, toHie b] - -instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where - toHie (L span top) = concatM $ makeNode top span : case top of - HsCmdTop _ cmd -> - [ toHie cmd - ] - -instance HiePass p => ToHie (LHsCmd (GhcPass p)) where - toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of - HsCmdArrApp _ a b _ _ -> - [ toHie a - , toHie b - ] - HsCmdArrForm _ a _ _ cmdtops -> - [ toHie a - , toHie cmdtops - ] - HsCmdApp _ a b -> - [ toHie a - , toHie b - ] - HsCmdLam _ mg -> - [ toHie mg - ] - HsCmdPar _ a -> - [ toHie a - ] - HsCmdCase _ expr alts -> - [ toHie expr - , toHie alts - ] - HsCmdLamCase _ alts -> - [ toHie alts - ] - HsCmdIf _ _ a b c -> - [ toHie a - , toHie b - , toHie c - ] - HsCmdLet _ binds cmd' -> - [ toHie $ RS (mkLScope cmd') binds - , toHie cmd' - ] - HsCmdDo _ (L ispan stmts) -> - [ locOnly ispan - , toHie $ listScopes NoScope stmts - ] - XCmd _ -> [] - -instance ToHie (TyClGroup GhcRn) where - toHie TyClGroup{ group_tyclds = classes - , group_roles = roles - , group_kisigs = sigs - , group_instds = instances } = - concatM - [ toHie classes - , toHie sigs - , toHie roles - , toHie instances - ] - -instance ToHie (LTyClDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamDecl {tcdFam = fdecl} -> - [ toHie (L span fdecl) - ] - SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> - [ toHie $ C (Decl SynDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars - , toHie typ - ] - DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> - [ toHie $ C (Decl DataDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars - , toHie defn - ] - where - quant_scope = mkLScope $ dd_ctxt defn - rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScope $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn - deriv_sc = mkLScope $ dd_derivs defn - ClassDecl { tcdCtxt = context - , tcdLName = name - , tcdTyVars = vars - , tcdFDs = deps - , tcdSigs = sigs - , tcdMeths = meths - , tcdATs = typs - , tcdATDefs = deftyps - } -> - [ toHie $ C (Decl ClassDec $ getRealSpan span) name - , toHie context - , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars - , toHie deps - , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs - , toHie $ fmap (BC InstanceBind ModuleScope) meths - , toHie typs - , concatMapM (locOnly . getLoc) deftyps - , toHie deftyps - ] - where - context_scope = mkLScope context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] - -instance ToHie (LFamilyDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamilyDecl _ info name vars _ sig inj -> - [ toHie $ C (Decl FamDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [rhsSpan]) vars - , toHie info - , toHie $ RS injSpan sig - , toHie inj - ] - where - rhsSpan = sigSpan `combineScopes` injSpan - sigSpan = mkScope $ getLoc sig - injSpan = maybe NoScope (mkScope . getLoc) inj - -instance ToHie (FamilyInfo GhcRn) where - toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (locOnly . getLoc) eqns - , toHie $ map go eqns - ] - where - go (L l ib) = TS (ResolvedScopes [mkScope l]) ib - toHie _ = pure [] - -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where - toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of - NoSig _ -> - [] - KindSig _ k -> - [ toHie k - ] - TyVarSig _ bndr -> - [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr - ] - -instance ToHie (Located (FunDep (Located Name))) where - toHie (L span fd@(lhs, rhs)) = concatM $ - [ makeNode fd span - , toHie $ map (C Use) lhs - , toHie $ map (C Use) rhs - ] - -instance (ToHie rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where - toHie (TS _ f) = toHie f - -instance (ToHie rhs, HasLoc rhs) - => ToHie (FamEqn GhcRn rhs) where - toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie pats - , toHie rhs - ] - where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc rhs) - -instance ToHie (LInjectivityAnn GhcRn) where - toHie (L span ann) = concatM $ makeNode ann span : case ann of - InjectivityAnn lhs rhs -> - [ toHie $ C Use lhs - , toHie $ map (C Use) rhs - ] - -instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM - [ toHie ctx - , toHie mkind - , toHie cons - , toHie derivs - ] - -instance ToHie (HsDeriving GhcRn) where - toHie (L span clauses) = concatM - [ locOnly span - , toHie clauses - ] - -instance ToHie (LHsDerivingClause GhcRn) where - toHie (L span cl) = concatM $ makeNode cl span : case cl of - HsDerivingClause _ strat (L ispan tys) -> - [ toHie strat - , locOnly ispan - , toHie $ map (TS (ResolvedScopes [])) tys - ] - -instance ToHie (Located (DerivStrategy GhcRn)) where - toHie (L span strat) = concatM $ makeNode strat span : case strat of - StockStrategy -> [] - AnyclassStrategy -> [] - NewtypeStrategy -> [] - ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] - -instance ToHie (Located OverlapMode) where - toHie (L span _) = locOnly span - -instance ToHie a => ToHie (HsScaled GhcRn a) where - toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] - -instance ToHie (LConDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars - , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> - [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , concatM $ [ bindingsOnly bindings - , toHie $ tvScopes resScope NoScope exp_vars ] - , toHie ctx - , toHie args - , toHie typ - ] - where - rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope args - tyScope = mkLScope typ - resScope = ResolvedScopes [ctxScope, rhsScope] - bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars - ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> - [ toHie $ C (Decl ConDec $ getRealSpan span) name - , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars - , toHie ctx - , toHie dets - ] - where - rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope dets - where condecl_scope :: HsConDeclDetails p -> Scope - condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs - InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) - (mkLScope (hsScaledThing b)) - RecCon x -> mkLScope x - -instance ToHie (Located [LConDeclField GhcRn]) where - toHie (L span decls) = concatM $ - [ locOnly span - , toHie decls - ] - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where - toHie (TS sc (HsIB ibrn a)) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn - , toHie $ TS sc a - ] - where span = loc a - -instance ( HasLoc thing - , ToHie (TScoped thing) - ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where - toHie (TS sc (HsWC names a)) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names - , toHie $ TS sc a - ] - where span = loc a - -instance ToHie (LStandaloneKindSig GhcRn) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] - -instance ToHie (StandaloneKindSig GhcRn) where - toHie sig = concatM $ case sig of - StandaloneKindSig _ name typ -> - [ toHie $ C TyDecl name - , toHie $ TS (ResolvedScopes []) typ - ] - -instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where - toHie (SC (SI styp msp) (L sp sig)) = - case hiePass @p of - HieTc -> pure [] - HieRn -> concatM $ makeNode sig sp : case sig of - TypeSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - PatSynSig _ names typ -> - [ toHie $ map (C TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ - ] - ClassOpSig _ _ names typ -> - [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names - _ -> toHie $ map (C $ TyDecl) names - , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ - ] - IdSig _ _ -> [] - FixSig _ fsig -> - [ toHie $ L sp fsig - ] - InlineSig _ name _ -> - [ toHie $ (C Use) name - ] - SpecSig _ name typs _ -> - [ toHie $ (C Use) name - , toHie $ map (TS (ResolvedScopes [])) typs - ] - SpecInstSig _ _ typ -> - [ toHie $ TS (ResolvedScopes []) typ - ] - MinimalSig _ _ form -> - [ toHie form - ] - SCCFunSig _ _ name mtxt -> - [ toHie $ (C Use) name - , maybe (pure []) (locOnly . getLoc) mtxt - ] - CompleteMatchSig _ _ (L ispan names) typ -> - [ locOnly ispan - , toHie $ map (C Use) names - , toHie $ fmap (C Use) typ - ] - -instance ToHie (LHsType GhcRn) where - toHie x = toHie $ TS (ResolvedScopes []) x - -instance ToHie (TScoped (LHsType GhcRn)) where - toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of - HsForAllTy _ tele body -> - let scope = mkScope $ getLoc body in - [ case tele of - HsForAllVis { hsf_vis_bndrs = bndrs } -> - toHie $ tvScopes tsc scope bndrs - HsForAllInvis { hsf_invis_bndrs = bndrs } -> - toHie $ tvScopes tsc scope bndrs - , toHie body - ] - HsQualTy _ ctx body -> - [ toHie ctx - , toHie body - ] - HsTyVar _ _ var -> - [ toHie $ C Use var - ] - HsAppTy _ a b -> - [ toHie a - , toHie b - ] - HsAppKindTy _ ty ki -> - [ toHie ty - , toHie $ TS (ResolvedScopes []) ki - ] - HsFunTy _ w a b -> - [ toHie (arrowToHsType w) - , toHie a - , toHie b - ] - HsListTy _ a -> - [ toHie a - ] - HsTupleTy _ _ tys -> - [ toHie tys - ] - HsSumTy _ tys -> - [ toHie tys - ] - HsOpTy _ a op b -> - [ toHie a - , toHie $ C Use op - , toHie b - ] - HsParTy _ a -> - [ toHie a - ] - HsIParamTy _ ip ty -> - [ toHie ip - , toHie ty - ] - HsKindSig _ a b -> - [ toHie a - , toHie b - ] - HsSpliceTy _ a -> - [ toHie $ L span a - ] - HsDocTy _ a _ -> - [ toHie a - ] - HsBangTy _ _ ty -> - [ toHie ty - ] - HsRecTy _ fields -> - [ toHie fields - ] - HsExplicitListTy _ _ tys -> - [ toHie tys - ] - HsExplicitTupleTy _ tys -> - [ toHie tys - ] - HsTyLit _ _ -> [] - HsWildCardTy _ -> [] - HsStarTy _ _ -> [] - XHsType _ -> [] - -instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where - toHie (HsValArg tm) = toHie tm - toHie (HsTypeArg _ ty) = toHie ty - toHie (HsArgPar sp) = locOnly sp - -instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where - toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ _ var -> - [ toHie $ C (TyVarBind sc tsc) var - ] - KindedTyVar _ _ var kind -> - [ toHie $ C (TyVarBind sc tsc) var - , toHie kind - ] - -instance ToHie (TScoped (LHsQTyVars GhcRn)) where - toHie (TS sc (HsQTvs implicits vars)) = concatM $ - [ bindingsOnly bindings - , toHie $ tvScopes sc NoScope vars - ] - where - varLoc = loc vars - bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits - -instance ToHie (LHsContext GhcRn) where - toHie (L span tys) = concatM $ - [ locOnly span - , toHie tys - ] - -instance ToHie (LConDeclField GhcRn) where - toHie (L span field) = concatM $ makeNode field span : case field of - ConDeclField _ fields typ _ -> - [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields - , toHie typ - ] - -instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where - toHie (From expr) = toHie expr - toHie (FromThen a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromTo a b) = concatM $ - [ toHie a - , toHie b - ] - toHie (FromThenTo a b c) = concatM $ - [ toHie a - , toHie b - , toHie c - ] - -instance ToHie (LSpliceDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - SpliceDecl _ splice _ -> - [ toHie splice - ] - -instance ToHie (HsBracket a) where - toHie _ = pure [] - -instance ToHie PendingRnSplice where - toHie _ = pure [] - -instance ToHie PendingTcSplice where - toHie _ = pure [] - -instance ToHie (LBooleanFormula (Located Name)) where - toHie (L span form) = concatM $ makeNode form span : case form of - Var a -> - [ toHie $ C Use a - ] - And forms -> - [ toHie forms - ] - Or forms -> - [ toHie forms - ] - Parens f -> - [ toHie f - ] - -instance ToHie (Located HsIPName) where - toHie (L span e) = makeNode e span - -instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where - toHie (L span sp) = concatM $ makeNode sp span : case sp of - HsTypedSplice _ _ _ expr -> - [ toHie expr - ] - HsUntypedSplice _ _ _ expr -> - [ toHie expr - ] - HsQuasiQuote _ _ _ ispan _ -> - [ locOnly ispan - ] - HsSpliced _ _ _ -> - [] - XSplice x -> case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> noExtCon x - GhcRn -> noExtCon x -#endif - GhcTc -> case x of - HsSplicedT _ -> [] - -instance ToHie (LRoleAnnotDecl GhcRn) where - toHie (L span annot) = concatM $ makeNode annot span : case annot of - RoleAnnotDecl _ var roles -> - [ toHie $ C Use var - , concatMapM (locOnly . getLoc) roles - ] - -instance ToHie (LInstDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ClsInstD _ d -> - [ toHie $ L span d - ] - DataFamInstD _ d -> - [ toHie $ L span d - ] - TyFamInstD _ d -> - [ toHie $ L span d - ] - -instance ToHie (LClsInstDecl GhcRn) where - toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl - , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl - , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl - , toHie $ cid_tyfam_insts decl - , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl - , toHie $ cid_datafam_insts decl - , toHie $ cid_overlap_mode decl - ] - -instance ToHie (LDataFamInstDecl GhcRn) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (LTyFamInstDecl GhcRn) where - toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d - -instance ToHie (Context a) - => ToHie (PatSynFieldContext (RecordPatSynField a)) where - toHie (PSC sp (RecordPatSynField a b)) = concatM $ - [ toHie $ C (RecField RecFieldDecl sp) a - , toHie $ C Use b - ] - -instance ToHie (LDerivDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DerivDecl _ typ strat overlap -> - [ toHie $ TS (ResolvedScopes []) typ - , toHie strat - , toHie overlap - ] - -instance ToHie (LFixitySig GhcRn) where - toHie (L span sig) = concatM $ makeNode sig span : case sig of - FixitySig _ vars _ -> - [ toHie $ map (C Use) vars - ] - -instance ToHie (LDefaultDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - DefaultDecl _ typs -> - [ toHie typs - ] - -instance ToHie (LForeignDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> - [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name - , toHie $ TS (ResolvedScopes []) sig - , toHie fi - ] - ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> - [ toHie $ C Use name - , toHie $ TS (ResolvedScopes []) sig - , toHie fe - ] - -instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ - [ locOnly a - , locOnly b - , locOnly c - ] - -instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = concatM $ - [ locOnly a - , locOnly b - ] - -instance ToHie (LWarnDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warnings _ _ warnings -> - [ toHie warnings - ] - -instance ToHie (LWarnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - Warning _ vars _ -> - [ toHie $ map (C Use) vars - ] - -instance ToHie (LAnnDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsAnnotation _ _ prov expr -> - [ toHie prov - , toHie expr - ] - -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where - toHie (ValueAnnProvenance a) = toHie $ C Use a - toHie (TypeAnnProvenance a) = toHie $ C Use a - toHie ModuleAnnProvenance = pure [] - -instance ToHie (LRuleDecls GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - HsRules _ _ rules -> - [ toHie rules - ] - -instance ToHie (LRuleDecl GhcRn) where - toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span - , locOnly $ getLoc rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs - , toHie exprA - , toHie exprB - ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope exprB - -instance ToHie (RScoped (LRuleBndr GhcRn)) where - toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - RuleBndr _ var -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - ] - RuleBndrSig _ var typ -> - [ toHie $ C (ValBind RegularBind sc Nothing) var - , toHie $ TS (ResolvedScopes [sc]) typ - ] - -instance ToHie (LImportDecl GhcRn) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> - [ toHie $ IEC Import name - , toHie $ fmap (IEC ImportAs) as - , maybe (pure []) goIE hidden - ] - where - goIE (hiding, (L sp liens)) = concatM $ - [ locOnly sp - , toHie $ map (IEC c) liens - ] - where - c = if hiding then ImportHiding else Import - -instance ToHie (IEContext (LIE GhcRn)) where - toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of - IEVar _ n -> - [ toHie $ IEC c n - ] - IEThingAbs _ n -> - [ toHie $ IEC c n - ] - IEThingAll _ n -> - [ toHie $ IEC c n - ] - IEThingWith _ n _ ns flds -> - [ toHie $ IEC c n - , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds - ] - IEModuleContents _ n -> - [ toHie $ IEC c n - ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] - IEDocNamed _ _ -> [] - -instance ToHie (IEContext (LIEWrappedName Name)) where - toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of - IEName n -> - [ toHie $ C (IEThing c) n - ] - IEPattern p -> - [ toHie $ C (IEThing c) p - ] - IEType n -> - [ toHie $ C (IEThing c) n - ] - -instance ToHie (IEContext (Located (FieldLbl Name))) where - toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of - FieldLabel _ _ n -> - [ toHie $ C (IEThing c) $ L span n - ] From 158b80b9e0b26e1f7d190f1976d116f523450382 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 19:19:05 +0800 Subject: [PATCH 63/86] hie-compat: Reexport the original version of HieBin --- hie-compat/src-ghc901/Compat/HieBin.hs | 367 +------------------------ 1 file changed, 2 insertions(+), 365 deletions(-) diff --git a/hie-compat/src-ghc901/Compat/HieBin.hs b/hie-compat/src-ghc901/Compat/HieBin.hs index 75989759db..254e1db6d3 100644 --- a/hie-compat/src-ghc901/Compat/HieBin.hs +++ b/hie-compat/src-ghc901/Compat/HieBin.hs @@ -1,371 +1,8 @@ {- Binary serialization for .hie files. -} -{- HLINT ignore -} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -module Compat.HieBin - ( readHieFile - , readHieFileWithVersion - , HieHeader - , writeHieFile - , HieName(..) - , toHieName - , HieFileResult(..) - , hieMagic - , hieNameOcc - , NameCacheUpdater(..) - ) +module Compat.HieBin ( module GHC.Iface.Ext.Binary) where -import GHC.Settings.Utils ( maybeRead ) -import GHC.Settings.Config ( cProjectVersion ) --- import GHC.Prelude -import GHC.Utils.Binary -import GHC.Iface.Binary ( getDictFastString ) -import GHC.Data.FastMutInt -import GHC.Data.FastString ( FastString ) -import GHC.Types.Name -import GHC.Types.Name.Cache -import GHC.Utils.Outputable -import GHC.Builtin.Utils -import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique.Supply ( takeUniqFromSupply ) -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Iface.Env (NameCacheUpdater(..)) --- 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 GHC.Iface.Ext.Types - -data HieSymbolTable = HieSymbolTable - { hie_symtab_next :: !FastMutInt - , hie_symtab_map :: !(IORef (UniqFM Name (Int, HieName))) - } - -data HieDictionary = HieDictionary - { hie_dict_next :: !FastMutInt -- The next index to use - , hie_dict_map :: !(IORef (UniqFM FastString (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 initial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName))) - 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_Directly 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_Directly out unique (j, f) - -putSymbolTable :: BinHandle -> Int -> UniqFM Name (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 - -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 "GHC.Iface.Ext.Binary.getHieName: invalid tag" +import GHC.Iface.Ext.Binary From 83cf34edea0c33b3d5b547955881e0be04888568 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 20:38:25 +0800 Subject: [PATCH 64/86] Add missing ghc-api-compat --- hls-plugin-api/hls-plugin-api.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 11ee0eb004..84de4c7f33 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -44,6 +44,7 @@ library , Diff ^>=0.4.0 , dlist , ghc + , ghc-api-compat , hashable , hslogger , lens From 8e03c8d08a51a69024c154bf93408a4595b45f8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 29 May 2021 20:39:23 +0800 Subject: [PATCH 65/86] Fix ghc9 build for ModuleName --- .../src/Ide/Plugin/ModuleName.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 637fa3f02e..0348690b80 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-} @@ -26,17 +27,13 @@ import Data.String (IsString) import qualified Data.Text as T import Development.IDE (GetParsedModule (GetParsedModule), GhcSession (GhcSession), IdeState, - List (..), NormalizedFilePath, - Position (Position), Range (Range), evalGhcEnv, hscEnvWithImportPaths, realSrcSpanToRange, runAction, - toNormalizedUri, uriToFilePath', - use, use_) -import Development.IDE.GHC.Compat (GenLocated (L), - SrcSpan (RealSrcSpan), - getSessionDynFlags, hsmodName, - importPaths, pm_parsed_source, - unLoc) + uriToFilePath', use, use_) +import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, + hsmodName, importPaths, + pattern OldRealSrcSpan, + pm_parsed_source, unLoc) import Ide.Types import Language.LSP.Server import Language.LSP.Types @@ -132,7 +129,7 @@ pathModuleName state normFilePath filePath codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) codeModuleName state nfp = runMaybeT $ do pm <- MaybeT . runAction "ModuleName.GetParsedModule" state $ use GetParsedModule nfp - L (RealSrcSpan l) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm + L (OldRealSrcSpan l) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm pure (realSrcSpanToRange l, T.pack $ show m) -- traceAs :: Show a => String -> a -> a From 10bf7929b8110d6547aad50f52a2230aae5aab87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 09:21:56 +0800 Subject: [PATCH 66/86] Add more conditionals on flags for tests --- test/functional/Command.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/functional/Command.hs b/test/functional/Command.hs index 871a2d82ba..d937879e8e 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -8,6 +8,7 @@ import Language.LSP.Types as LSP import Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command +import Test.Hls.Flags (requiresEvalPlugin) tests :: TestTree tests = testGroup "commands" [ @@ -19,7 +20,7 @@ tests = testGroup "commands" [ liftIO $ do all f cmds @? "All prefixed" not (null cmds) @? "Commands aren't empty" - , testCase "get de-prefixed" $ + , requiresEvalPlugin $ testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request SWorkspaceExecuteCommand From 6c5d5307eeed944d4203884e4d29dc01c90a7a54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 14:34:23 +0800 Subject: [PATCH 67/86] Add a separate cabal.project file for ghc9 As far as I know, this is the only way to disable the packages who's dependencies doesn't compile in GHC9 yet. --- cabal-ghc901.project | 159 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) create mode 100644 cabal-ghc901.project diff --git a/cabal-ghc901.project b/cabal-ghc901.project new file mode 100644 index 0000000000..8c6682c9be --- /dev/null +++ b/cabal-ghc901.project @@ -0,0 +1,159 @@ +packages: + ./ + ./hie-compat + ./shake-bench + ./hls-graph + ./ghcide + ./hls-plugin-api + ./hls-test-utils + -- ./plugins/hls-tactics-plugin + -- ./plugins/hls-brittany-plugin + -- ./plugins/hls-stylish-haskell-plugin + -- ./plugins/hls-fourmolu-plugin + ./plugins/hls-class-plugin + ./plugins/hls-eval-plugin + ./plugins/hls-explicit-imports-plugin + ./plugins/hls-refine-imports-plugin + ./plugins/hls-hlint-plugin + ./plugins/hls-retrie-plugin + ./plugins/hls-haddock-comments-plugin + -- ./plugins/hls-splice-plugin + ./plugins/hls-floskell-plugin + ./plugins/hls-pragmas-plugin + ./plugins/hls-module-name-plugin + -- ./plugins/hls-ormolu-plugin +tests: true + +package * + ghc-options: -haddock + test-show-details: direct + +source-repository-package + type: git + location: https://github.com/jwaldmann/blaze-textual.git + tag: d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/bos/blaze-textual/issues/13 + +source-repository-package + type: git + location: https://github.com/mithrandi/czipwith.git + tag: b6245884ae83e00dd2b5261762549b37390179f8 + -- https://github.com/lspitzner/czipwith/pull/2 + + +source-repository-package + type: git + location: https://github.com/jneira/hie-bios/ + tag: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 + -- https://github.com/mpickering/hie-bios/pull/285 + +source-repository-package + type: git + location: https://github.com/hsyl20/ghc-api-compat + tag: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 + +source-repository-package + type: git + location: https://github.com/anka-213/th-extras + tag: 57a97b4df128eb7b360e8ab9c5759392de8d1659 +-- https://github.com/mokus0/th-extras/pull/8 +-- https://github.com/mokus0/th-extras/issues/7 + +-- source-repository-package +-- type: git +-- location: https://github.com/anka-213/ghc-check +-- tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d +-- -- https://github.com/pepeiborra/ghc-check/pull/12 + +source-repository-package + type: git + location: https://github.com/anka-213/dependent-sum + tag: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + subdir: dependent-sum-template +-- https://github.com/obsidiansystems/dependent-sum/pull/57 + +source-repository-package + type: git + location: https://github.com/anka-213/HieDb + tag: a3f7521f6c5af1b977040cce09c8f7354f8984eb +-- https://github.com/wz1000/HieDb/pull/31 + +source-repository-package + type: git + location: https://github.com/anka-213/lsp + tag: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee + subdir: lsp-types + subdir: lsp + subdir: lsp-test +-- https://github.com/haskell/lsp/pull/312 + +source-repository-package + type: git + location: https://github.com/diagrams/active + tag: ca23431a8dfa013992f9164ccc882a3277361f17 +-- https://github.com/diagrams/active/pull/36 + +write-ghc-environment-files: never + +index-state: 2021-05-21T05:01:41Z + +constraints: + -- Diagrams doesn't support optparse-applicative >= 0.16 yet + optparse-applicative < 0.16 + -- These plugins doesn't work on GHC9 yet + , haskell-language-server -brittany -class -eval -fourmolu -modulename -ormolu -splice -stylishhaskell -tactic -refineImports + + +allow-newer: + -- -- Broken on ghc9, but let's pretend it's not so we can build the other things + -- brittany:base, + -- brittany:ghc, + -- brittany:ghc-boot-th, + -- butcher:base, + -- fourmolu:ghc-lib-parser, + -- ormolu:ghc-lib-parser, + -- stylish-haskell:ghc-lib-parser, + -- stylish-haskell:Cabal, + -- multistate:base, + -- ghc-source-gen:ghc, + + active:base, + assoc:base, + cryptohash-md5:base, + cryptohash-sha1:base, + constraints-extras:template-haskell, + data-tree-print:base, + deepseq:base, + dependent-sum:some, + dependent-sum:constraints, + diagrams-contrib:base, + diagrams-contrib:lens, + diagrams-contrib:random, + diagrams-core:base, + diagrams-core:lens, + diagrams-lib:base, + diagrams-lib:lens, + diagrams-postscript:base, + diagrams-postscript:lens, + diagrams-svg:base, + diagrams-svg:lens, + dual-tree:base, + -- Does this make any sense? + entropy:Cabal, + force-layout:base, + force-layout:lens, + floskell:ghc-prim, + floskell:base, + hashable:base, + hslogger:base, + monoid-extras:base, + newtype-generics:base, + parallel:base, + regex-base:base, + regex-tdfa:base, + statestack:base, + svg-builder:base, + these:base, + time-compat:base + From bb37b7b298f4fd654599894d33bc6f201c38f729 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 14:32:17 +0800 Subject: [PATCH 68/86] Fix and re-enable CI for GHC9 --- .github/workflows/test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index e6a619cf0d..43db81446c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -33,7 +33,7 @@ jobs: strategy: fail-fast: true matrix: - ghc: ["8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] + ghc: ["9.0.1", "8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] os: [ubuntu-latest, macOS-latest] include: # only test supported ghc major versions @@ -107,7 +107,7 @@ jobs: run: cabal update - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} - run: cabal configure --constraint "haskell-language-server -class -eval -refineImports -tactic -moduleName -splice -fourmolu -ormolu -stylishHaskell -brittany" + run: cp cabal-ghc901.project cabal.project # Need this to work around filepath length limits in Windows - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} From 34a752aa9f1279f53d2210c73ebc4e3706f96edc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 14:42:23 +0800 Subject: [PATCH 69/86] Remove accidental non-breaking space --- test/functional/Progress.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 365b7c2dfb..a4b9ac4fa1 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -38,7 +38,7 @@ tests = let cmd = evalLens ^?! L.command . _Just _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) expectProgressReports ["Evaluating"] - , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do + , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" From 6e8d9280874f8288b882cf5d4260379759dc2f7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 20:59:17 +0800 Subject: [PATCH 70/86] Fix CI build for ghc9 Since we are changing the flags for haskell-language-server, which CI renames to hls, we need to use the shortened name in those flags as well --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 43db81446c..6c7e147972 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -115,7 +115,7 @@ jobs: run: | sed -i.bak -e 's/haskell-language-server/hls/g' \ -e 's/haskell_language_server/hls/g' \ - haskell-language-server.cabal + haskell-language-server.cabal cabal.project sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ src/**/*.hs exe/*.hs From 8e9e98cb0dc478c3a00dd2e3067fa78829ed4997 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 21:52:33 +0800 Subject: [PATCH 71/86] Run tests for ghc9 in CI --- .github/workflows/test.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 6c7e147972..9f6d78e52b 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -37,6 +37,9 @@ jobs: os: [ubuntu-latest, macOS-latest] include: # only test supported ghc major versions + - os: ubuntu-latest + ghc: '9.0.1' + test: true - os: ubuntu-latest ghc: '8.10.4' test: true From 7a1c651cac01d635389d1996db9109daa1f7383b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 30 May 2021 22:05:03 +0800 Subject: [PATCH 72/86] Minor CI changes --- .github/workflows/test.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 9f6d78e52b..62ef35c536 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -91,6 +91,11 @@ jobs: echo "CABAL_STORE_DIR=~/.cabal/store" >> $GITHUB_ENV echo "CABAL_PKGS_DIR=~/.cabal/packages" >> $GITHUB_ENV + # Needs to be before Cache Cabal so the cache can detect changes to the modified cabal.project file + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} + name: Use modified cabal.project for ghc9 + run: cp cabal-ghc901.project cabal.project + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} name: Cache Cabal uses: actions/cache@v2 @@ -109,9 +114,6 @@ jobs: - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} run: cabal update - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} - run: cp cabal-ghc901.project cabal.project - # Need this to work around filepath length limits in Windows - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} name: Shorten binary names From de075bf51057d1bf076315d04970523e0a797628 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 31 May 2021 12:01:11 +0800 Subject: [PATCH 73/86] Use proper values when enriching hie --- ghcide/src/Development/IDE/Core/Compile.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 0dd7777cd9..4d64e978dd 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -478,11 +478,11 @@ generateHieAsts hscEnv tcm = let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm #if MIN_VERSION_ghc(9,0,1) - -- TODO: Use some proper values here! - evBinds = emptyBag @EvBind :: Bag EvBind - clsInsts = [] :: [ClsInst] - tyCons = [] :: [TyCon] - Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) evBinds clsInsts tyCons + ts = tmrTypechecked tcm :: TcGblEnv + top_ev_binds = tcg_ev_binds ts :: Bag EvBind + insts = tcg_insts ts :: [ClsInst] + tcs = tcg_tcs ts :: [TyCon] + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) #endif From 88122fbcf6f4d64356b69df0099b263a8a04e542 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 31 May 2021 12:09:10 +0800 Subject: [PATCH 74/86] Don't try to test hls-refine-imports-plugin on ghc9 --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 62ef35c536..34f7d4860b 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -186,6 +186,6 @@ jobs: name: Test hls-tactics-plugin test suite run: cabal test hls-tactics-plugin --test-options="-j1 --rerun-update" || cabal test hls-tactics-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-tactics-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" From 79f5feef3f9c5d83cf52078bfb5428e3d014a5a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 31 May 2021 12:26:14 +0800 Subject: [PATCH 75/86] Update comment about ghc9 crashing on initDynLinker --- ghcide/session-loader/Development/IDE/Session.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8a6091e91a..cbf6655bda 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -527,7 +527,8 @@ emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession #if !MIN_VERSION_ghc(9,0,0) - -- This causes ghc9 to crash + -- This causes ghc9 to crash with the error: + -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env #endif pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } From 4065ac8394065f8aa15b1b36e0d56e3ba7762e44 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 31 May 2021 13:15:19 +0800 Subject: [PATCH 76/86] setSessionDynamicFlags to prevent ghc9 from crashing The only way to set the dynamic linker is with the function `setSessionDynFlags` so we call it with the result from `getSessionDynFlags` to give it a (hopefully sensible) argument. See also this commit: https://gitlab.haskell.org/ghc/ghc/commit/18757cab04c5c5c48eaceea19469d4811c5d0371 --- ghcide/session-loader/Development/IDE/Session.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cbf6655bda..431d6d4714 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -525,12 +525,15 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do +#if MIN_VERSION_ghc(9,0,0) + -- Without the seemingly redundant `getSessionDynFlags >>= setSessionDynFlags` + -- the line `initDynLinker env` would crash with the errror: + -- `Couldn't find a target code interpreter. Try with -fexternal-interpreter` + env <- runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession +#else env <- runGhc (Just libDir) getSession -#if !MIN_VERSION_ghc(9,0,0) - -- This causes ghc9 to crash with the error: - -- Couldn't find a target code interpreter. Try with -fexternal-interpreter - initDynLinker env #endif + initDynLinker env pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails From 15d464e2b9affd1ab7eaf7fcf8329b1169a159bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 1 Jun 2021 16:41:40 +0800 Subject: [PATCH 77/86] Revert "setSessionDynamicFlags to prevent ghc9 from crashing" This reverts commit 4065ac8394065f8aa15b1b36e0d56e3ba7762e44. That change made the "ghcide.cradle.muli" tests fail. --- ghcide/session-loader/Development/IDE/Session.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 431d6d4714..cbf6655bda 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -525,15 +525,12 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do -#if MIN_VERSION_ghc(9,0,0) - -- Without the seemingly redundant `getSessionDynFlags >>= setSessionDynFlags` - -- the line `initDynLinker env` would crash with the errror: - -- `Couldn't find a target code interpreter. Try with -fexternal-interpreter` - env <- runGhc (Just libDir) $ getSessionDynFlags >>= setSessionDynFlags >> getSession -#else env <- runGhc (Just libDir) getSession -#endif +#if !MIN_VERSION_ghc(9,0,0) + -- This causes ghc9 to crash with the error: + -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env +#endif pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails From 7f4d4abc8c645fa6f6cf484b76bb486d328b1f3b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Tue, 1 Jun 2021 17:46:54 +0800 Subject: [PATCH 78/86] Simplify logic in hls-hlint-plugin.cabal --- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 27 +++++++++++-------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index bbdbae2c78..93c1a900c4 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -28,7 +28,8 @@ flag hlint33 default: True manual: False description: - Hlint-3.3 doesn't support older ghc/ghc-lib versions, so we can use hlint-3.2 for backwards compat + Hlint-3.3 doesn't support versions ghc-lib < 9.0.1 nor ghc <= 8.6, so we can use hlint-3.2 for backwards compat + This flag can be removed when all dependencies support ghc-lib-9.0.1 and we drop support for ghc-8.6 library exposed-modules: Ide.Plugin.Hlint @@ -61,29 +62,33 @@ library , unordered-containers if (flag(hlint33)) + -- This mirrors the logic in hlint.cabal for hlint-3.3 + -- https://github.com/ndmitchell/hlint/blob/d3576de4529d8df6cca5a345f5b7e04474ff7bff/hlint.cabal#L79-L88 + -- so we can make sure that we do the same thing as hlint build-depends: hlint ^>=3.3 - else - build-depends: hlint ^>=3.2 - - if (!flag(ghc-lib) && (!flag(hlint33) && impl(ghc >=8.10.1) || flag(hlint33) && impl(ghc >=9.0.1)) && impl(ghc <9.1.0)) - if (flag(hlint33)) + if (!flag(ghc-lib) && impl(ghc >=9.0.1) && impl(ghc <9.1.0)) build-depends: ghc ==9.0.* else - build-depends: ghc >=8.10 && < 9.0 - - else - if (flag(hlint33)) build-depends: , ghc , ghc-lib == 9.0.* , ghc-lib-parser-ex == 9.0.* + + cpp-options: -DHLINT_ON_GHC_LIB + + else + -- This mirrors the logic in hlint.cabal for hlint-3.2 + -- https://github.com/ndmitchell/hlint/blob/c7354e473c7d09213c8adc3dc94bf50a6eb4a42d/hlint.cabal#L79-L88 + build-depends: hlint ^>=3.2 + if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc < 8.11.0)) + build-depends: ghc >=8.10 && < 9.0 else build-depends: , ghc , ghc-lib ^>= 8.10.4.20210206 , ghc-lib-parser-ex ^>= 8.10 - cpp-options: -DHLINT_ON_GHC_LIB + cpp-options: -DHLINT_ON_GHC_LIB ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing From 51afd18b52b5aa402dc62a8aa6d537ad9e7f0dd3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 16:36:06 +0800 Subject: [PATCH 79/86] Add comment on OldRealSrcSpan --- plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 271e6140e2..9086ec8b58 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -102,6 +102,7 @@ import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- +-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan #if MIN_GHC_API_VERSION(9,0,0) pattern OldRealSrcSpan span <- RealSrcSpan span _ From a581c59db050d9b815e95545339e5b50bdccdc41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 16:40:10 +0800 Subject: [PATCH 80/86] Remove source overrides for non-ghc9 builds in cabal.project --- cabal.project | 78 --------------------------------------------------- 1 file changed, 78 deletions(-) diff --git a/cabal.project b/cabal.project index 7eef187c73..26b29981e7 100644 --- a/cabal.project +++ b/cabal.project @@ -28,72 +28,6 @@ package * ghc-options: -haddock test-show-details: direct -source-repository-package - type: git - location: https://github.com/jwaldmann/blaze-textual.git - tag: d8ee6cf80e27f9619d621c936bb4bda4b99a183f - -- https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f - -- https://github.com/bos/blaze-textual/issues/13 - -source-repository-package - type: git - location: https://github.com/mithrandi/czipwith.git - tag: b6245884ae83e00dd2b5261762549b37390179f8 - -- https://github.com/lspitzner/czipwith/pull/2 - - -source-repository-package - type: git - location: https://github.com/jneira/hie-bios/ - tag: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 - -- https://github.com/mpickering/hie-bios/pull/285 - -source-repository-package - type: git - location: https://github.com/hsyl20/ghc-api-compat - tag: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 - -source-repository-package - type: git - location: https://github.com/anka-213/th-extras - tag: 57a97b4df128eb7b360e8ab9c5759392de8d1659 --- https://github.com/mokus0/th-extras/pull/8 --- https://github.com/mokus0/th-extras/issues/7 - --- source-repository-package --- type: git --- location: https://github.com/anka-213/ghc-check --- tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d --- -- https://github.com/pepeiborra/ghc-check/pull/12 - -source-repository-package - type: git - location: https://github.com/anka-213/dependent-sum - tag: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 - subdir: dependent-sum-template --- https://github.com/obsidiansystems/dependent-sum/pull/57 - -source-repository-package - type: git - location: https://github.com/anka-213/HieDb - tag: a3f7521f6c5af1b977040cce09c8f7354f8984eb --- https://github.com/wz1000/HieDb/pull/31 - -source-repository-package - type: git - location: https://github.com/anka-213/lsp - tag: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee - subdir: lsp-types - subdir: lsp - subdir: lsp-test --- https://github.com/haskell/lsp/pull/312 - -source-repository-package - type: git - location: https://github.com/diagrams/active - tag: ca23431a8dfa013992f9164ccc882a3277361f17 --- https://github.com/diagrams/active/pull/36 - write-ghc-environment-files: never index-state: 2021-05-21T05:01:41Z @@ -103,18 +37,6 @@ constraints: optparse-applicative < 0.16 allow-newer: - -- -- Broken on ghc9, but let's pretend it's not so we can build the other things - -- brittany:base, - -- brittany:ghc, - -- brittany:ghc-boot-th, - -- butcher:base, - -- fourmolu:ghc-lib-parser, - -- ormolu:ghc-lib-parser, - -- stylish-haskell:ghc-lib-parser, - -- stylish-haskell:Cabal, - -- multistate:base, - -- ghc-source-gen:ghc, - active:base, assoc:base, cryptohash-md5:base, From 0ad1de142ca59528872cd5c2c217bdc0c0984a73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 16:41:11 +0800 Subject: [PATCH 81/86] Remove commented out code Co-authored-by: Pepe Iborra --- ghcide/src/Development/IDE/GHC/Util.hs | 3 --- ghcide/src/Development/IDE/Spans/Documentation.hs | 1 - ghcide/src/Development/IDE/Types/Options.hs | 3 --- 3 files changed, 7 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index 111f39e33a..fd13dd8f27 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -69,9 +69,6 @@ import OccName (parenSymOcc) import Outputable (Depth (..), Outputable, SDoc, neverQualify, ppr, showSDocUnsafe) --- import PackageConfig (PackageConfig) --- import Packages ( -- getPackageConfigMap, --- lookupPackage') import RdrName (nameRdrName, rdrNameOcc) import SrcLoc (mkRealSrcLoc) import StringBuffer diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 64db24541d..95cc889d40 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -36,7 +36,6 @@ import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri) import Name import NameEnv --- import Packages import SrcLoc (RealLocated) import TcRnTypes diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index e4136017f5..817481dfea 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -25,9 +25,6 @@ import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat as GHC import Development.IDE.Graph import Development.IDE.Types.Diagnostics --- import GHC hiding (parseModule, --- typecheckModule) --- import GhcPlugins as GHC hiding (fst3, (<>)) import Ide.Plugin.Config import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Types.Capabilities as LSP From cfaff77a7ed971aa5e4d4003c538a2828fcc253d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 16:49:48 +0800 Subject: [PATCH 82/86] Remove resolved question from comment "This code is only concerned with extracting argument names, so I don't see how multiplicity would be relevant here" https://github.com/haskell/haskell-language-server/pull/1649#discussion_r642606967 --- ghcide/src/Development/IDE/Plugin/Completions/Logic.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index f3678c1b7c..9f958f17e0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -266,7 +266,6 @@ mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI let (args, ret) = splitFunTys t in if isForAllTy ret then getArgs ret - -- TODO: Do we want to use multiplicity here? else Prelude.filter (not . isDictTy) $ map scaledThing args | isPiTy t = getArgs $ snd (splitPiTys t) #if MIN_VERSION_ghc(8,10,0) From fc35ff41a7da43594efa82ddf39c7746b763c8c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 17:17:12 +0800 Subject: [PATCH 83/86] ghc9: Update to latest version of LSP per --- cabal-ghc901.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 8c6682c9be..a4e56be8e8 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -82,7 +82,7 @@ source-repository-package source-repository-package type: git location: https://github.com/anka-213/lsp - tag: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee + tag: e96383ab19534128f12acc70a69fbc15d4f298cc subdir: lsp-types subdir: lsp subdir: lsp-test From 3a976cfbffad9b615f31d1377be569ace4603f79 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 17:21:00 +0800 Subject: [PATCH 84/86] cabal-ghc901.project: Remove commented out code --- cabal-ghc901.project | 6 ------ 1 file changed, 6 deletions(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index a4e56be8e8..0dea469d1a 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -60,12 +60,6 @@ source-repository-package -- https://github.com/mokus0/th-extras/pull/8 -- https://github.com/mokus0/th-extras/issues/7 --- source-repository-package --- type: git --- location: https://github.com/anka-213/ghc-check --- tag: 3cad1db8bd6ef0921713913be7e92fe2361bae4d --- -- https://github.com/pepeiborra/ghc-check/pull/12 - source-repository-package type: git location: https://github.com/anka-213/dependent-sum From 2e8d936206f1edb1496a2afd6c6e00fd4c6911b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sat, 5 Jun 2021 17:39:04 +0800 Subject: [PATCH 85/86] Update the lsp commit hash for stack as well --- stack-9.0.1.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index f8b50148a1..452167ea1b 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -86,7 +86,7 @@ extra-deps: # https://github.com/wz1000/HieDb/pull/31 - github: anka-213/lsp - commit: 3bf244fe0cf7ca9b895ae71fb526adba466ceaee + commit: e96383ab19534128f12acc70a69fbc15d4f298cc subdirs: - lsp-types - lsp From ec0895714b8fe78fa54bc5146ed0e4f1c98a2829 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Sun, 6 Jun 2021 05:24:12 +0800 Subject: [PATCH 86/86] Use a version of lsp without haskell/lsp#326 That patch was causing test failures, but the issues should be fixed for real at some point, so that patch can be incluede --- cabal-ghc901.project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-ghc901.project b/cabal-ghc901.project index 0dea469d1a..017783b414 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -76,7 +76,7 @@ source-repository-package source-repository-package type: git location: https://github.com/anka-213/lsp - tag: e96383ab19534128f12acc70a69fbc15d4f298cc + tag: tag-ghc-9.0.1-without-pr-326 subdir: lsp-types subdir: lsp subdir: lsp-test