From 974d33090a34772e7105a0cf862bc911c8a73838 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 1/5] 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 52ad40f17c49b528563d77d717a2c14be283561b 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 2/5] 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 60f78a1fe7977114deb53709f5c7ecb5259c9130 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 3/5] 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 5149eefd259bd2df23cf49ed1c5643b28a2db292 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 4/5] 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 7083e2e3fe6a7fdfdc9b58c3648858fdafb4fd7d 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 5/5] 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