hie-compat (empty) → 0.1.0.0
raw patch · 16 files changed
+8080/−0 lines, 16 filesdep +arraydep +basedep +bytestring
Dependencies added: array, base, bytestring, containers, directory, filepath, ghc, ghc-boot, ghc-lib, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +201/−0
- README.md +20/−0
- hie-compat.cabal +45/−0
- src-ghc810/Compat/HieAst.hs +1925/−0
- src-ghc810/Compat/HieBin.hs +399/−0
- src-ghc86/Compat/HieAst.hs +1783/−0
- src-ghc86/Compat/HieBin.hs +388/−0
- src-ghc86/Compat/HieDebug.hs +145/−0
- src-ghc86/Compat/HieTypes.hs +534/−0
- src-ghc86/Compat/HieUtils.hs +451/−0
- src-ghc88/Compat/HieAst.hs +1786/−0
- src-ghc88/Compat/HieBin.hs +389/−0
- src-reexport/Compat/HieDebug.hs +3/−0
- src-reexport/Compat/HieTypes.hs +3/−0
- src-reexport/Compat/HieUtils.hs +3/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hie-compat++## 0.1.0.0 -- 2020-10-19++* Initial Release
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2019 Zubin Duggal++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,20 @@+# hie-compat++Mainly a backport of [HIE+Files](https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files) for ghc 8.6, along+with a few other backports of fixes useful for `ghcide`++Fully compatible with `.hie` files natively produced by versions of GHC that support+them.++**THIS DOES NOT LET YOU READ HIE FILES WITH MISMATCHED VERSIONS OF GHC**++Backports included:++https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4037++https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4068++https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3199++https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2578
+ hie-compat.cabal view
@@ -0,0 +1,45 @@+cabal-version: 1.22+name: hie-compat+version: 0.1.0.0+synopsis: HIE files for GHC 8.6 and other HIE file backports+license: Apache-2.0+description:+ Backports for HIE files to GHC 8.6, along with a few other backports+ of HIE file related fixes for ghcide.++ THIS DOES NOT LET YOU READ HIE FILES WITH MISMATCHED VERSIONS OF GHC+license-file: LICENSE+author: Zubin Duggal+maintainer: zubin.duggal@gmail.com+build-type: Simple+extra-source-files: CHANGELOG.md README.md+category: Development++flag ghc-lib+ description: build against ghc-lib instead of the ghc package+ default: False+ manual: True++library+ default-language: Haskell2010+ build-depends:+ base < 4.15, array, bytestring, containers, directory, filepath, transformers+ if flag(ghc-lib)+ build-depends: ghc-lib+ else+ build-depends: ghc, ghc-boot++ exposed-modules:+ Compat.HieAst+ Compat.HieBin+ Compat.HieTypes+ Compat.HieDebug+ Compat.HieUtils++ if (impl(ghc > 8.5) && impl(ghc < 8.7) && !flag(ghc-lib))+ hs-source-dirs: src-ghc86+ if ((impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib))+ hs-source-dirs: src-ghc88 src-reexport+ if (impl(ghc > 8.9) && impl(ghc < 8.11))+ hs-source-dirs: src-ghc810 src-reexport+
+ src-ghc810/Compat/HieAst.hs view
@@ -0,0 +1,1925 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile++Main functions for .hie file generation+-}+{- HLINT ignore -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Compat.HieAst ( mkHieFile, enrichHie ) where++import GhcPrelude++import Avail ( Avails )+import Bag ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class ( FunDep )+import CoreUtils ( exprType )+import ConLike ( conLikeName )+import Desugar ( deSugarExpr )+import FieldLabel+import GHC.Hs+import HscTypes+import Module ( ModuleName, ml_hs_file )+import MonadUtils ( concatMapM, liftIO )+import Name ( Name, nameSrcSpan )+import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )+import SrcLoc+import TcHsSyn ( hsLitType, hsPatType )+import Type ( mkVisFunTys, Type )+import TysWiredIn ( mkListTy, mkSumTy )+import Var ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface ( mkIfaceExports )+import Panic++import HieTypes+import HieUtils++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 Data.Maybe ( listToMaybe )+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 `HieTypes`, 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 HieAst.++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 main/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.+-}+newtype HieState = HieState+ { name_remapping :: NameEnv Id+ }++initState :: HieState+initState = HieState emptyNameEnv++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 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 tc_binds = tcg_binds ts+ (asts', arr) <- getCompressedAsts tc_binds rs+ let Just src_file = ml_hs_file $ ms_location ms+ 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+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+ asts <- enrichHie ts rs+ return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ 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+ let spanFile children = case children of+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+ (realSrcSpanEnd $ nodeSpan $ last children)++ modulify xs =+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++ asts = HieASTs+ $ resolveTyVarScopes+ $ M.map (modulify . mergeSortAsts)+ $ M.fromListWith (++)+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++ flat_asts = concat+ [ tasts+ , rasts+ , imps+ , exps+ ]+ 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] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+ info = mempty{identInfo = S.singleton c}+ _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local tranformation, 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 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 (composeSrcSpan a)) $+ listScopes patScope (map dL xs)++-- | 'listScopes' specialised to 'TVScoped' things+tvScopes+ :: TyVarScope+ -> Scope+ -> [LHsTyVarBndr a]+ -> [TVScoped (LHsTyVarBndr 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+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explictly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+ GhcRn+ (Shielded (LHsType GhcRn)))+ ProtectedSig GhcTc = NoExtField++class ProtectSig a where+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+ loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+ protectSig _ _ = noExtField++instance ProtectSig GhcRn where+ protectSig sc (HsWC a (HsIB b sig)) =+ HsWC a (HsIB b (SH sc sig))+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec++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+ loc _ = noSrcSpan++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+ loc _ = noSrcSpan++{- Note [Real DataCon Name]+The typechecker subtitutes 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 Data a => 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 (Context (Located NoExtField)) where+ toHie _ = pure []++instance ToHie (TScoped NoExtField) where+ toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+ toHie (IEC c (L (RealSrcSpan span) mname)) =+ pure $ [Node (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')+ -> do+ m <- asks name_remapping+ let name = case lookupNameEnv m (varName name') of+ Just var -> var+ Nothing-> name'+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right $ varName name)+ (IdentifierDetails (Just $ varType name')+ (S.singleton context)))+ span+ []]+ _ -> pure []++instance ToHie (Context (Located Name)) where+ toHie c = case c of+ C context (L (RealSrcSpan span) name') -> do+ m <- asks name_remapping+ let name = case lookupNameEnv m name' of+ Just var -> varName var+ Nothing -> name'+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right name)+ (IdentifierDetails Nothing+ (S.singleton context)))+ span+ []]+ _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped Type) where+ toHie _ = pure []++instance HasType (LHsBind GhcRn) where+ getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+ getTypeNode (L spn bind) = case bind of+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+ _ -> makeNode bind spn++instance HasType (Located (Pat GhcRn)) where+ getTypeNode (dL -> L spn pat) = makeNode pat spn++instance HasType (Located (Pat GhcTc)) where+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+ getTypeNode (L spn e) = makeNode e spn++-- | 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 HasType (LHsExpr GhcTc) where+ getTypeNode e@(L spn e') = lift $+ -- Some expression forms have their type immediately available+ let tyOpt = case e' of+ HsLit _ l -> Just (hsLitType l)+ HsOverLit _ o -> Just (overLitType o)++ 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 <- 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 a -> Bool+ skipDesugaring e = case e of+ HsVar{} -> False+ HsUnboundVar{} -> False+ HsConLikeOut{} -> False+ HsRecFld{} -> False+ HsOverLabel{} -> False+ HsIPVar{} -> False+ HsWrap{} -> False+ _ -> True++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a (LHsExpr a))+ , ToHie (LHsExpr a)+ , ToHie (Located (PatSynBind a a))+ , HasType (LHsBind a)+ , ModifyState (IdP a)+ , Data (HsBind a)+ ) => ToHie (BindContext (LHsBind a)) where+ toHie (BC context scope b@(L span bind)) =+ concatM $ getTypeNode b : case bind of+ FunBind{fun_id = name, fun_matches = matches} ->+ [ toHie $ C (ValBind context scope $ getRealSpan span) name+ , toHie matches+ ]+ 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} ->+ [ local (modifyState xs) $ -- Note [Name Remapping]+ toHie $ fmap (BC context scope) binds+ ]+ PatSynBind _ psb ->+ [ toHie $ L span psb -- PatSynBinds only occur at the top level+ ]+ XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+ ) => ToHie (MatchGroup a body) where+ toHie mg = concatM $ case mg of+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+ [ pure $ locOnly span+ , toHie alts+ ]+ MG{} -> []+ XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (HsPatSynDir a)+ ) => ToHie (Located (PatSynBind a a)) 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 NoScope pat+ , toHie dir+ ]+ where+ lhsScope = combineScopes varScope detScope+ varScope = mkLScope var+ 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+ XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+ ) => ToHie (HsPatSynDir a) where+ toHie dir = case dir of+ ExplicitBidirectional mg -> toHie mg+ _ -> pure []++instance ( a ~ GhcPass p+ , ToHie body+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a body)+ , Data (Match a body)+ ) => ToHie (LMatch (GhcPass p) body) where+ toHie (L span m ) = concatM $ makeNode m span : 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+ ]+ XMatch _ -> []++instance ( ToHie (Context (Located a))+ ) => ToHie (HsMatchContext a) where+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+ toHie (StmtCtxt a) = toHie a+ toHie _ = pure []++instance ( ToHie (HsMatchContext a)+ ) => ToHie (HsStmtContext a) where+ toHie (PatGuard a) = toHie a+ toHie (ParStmtCtxt a) = toHie a+ toHie (TransStmtCtxt a) = toHie a+ toHie _ = pure []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+ , ToHie (LHsExpr a)+ , ToHie (TScoped (LHsSigWcType a))+ , ProtectSig a+ , ToHie (TScoped (ProtectedSig a))+ , HasType (LPat a)+ , Data (HsSplice a)+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where+ toHie (PS rsp scope pscope lpat@(dL -> 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 (dL 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+ ]+ ConPatIn c dets ->+ [ toHie $ C Use c+ , toHie $ contextify dets+ ]+ ConPatOut {pat_con = con, pat_args = dets}->+ [ toHie $ C Use $ fmap conLikeName 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+ , let cscope = mkLScope (dL pat) in+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])+ (protectSig @a cscope sig)+ -- See Note [Scoping Rules for SigPat]+ ]+ CoPat _ _ _ _ ->+ []+ XPat _ -> []+ where+ 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 body+ , ToHie (LGRHS a body)+ , ToHie (RScoped (LHsLocalBinds a))+ ) => ToHie (GRHSs a body) where+ toHie grhs = concatM $ case grhs of+ GRHSs _ grhss binds ->+ [ toHie grhss+ , toHie $ RS (mkScope $ grhss_span grhs) binds+ ]+ XGRHSs _ -> []++instance ( ToHie (Located body)+ , ToHie (RScoped (GuardLStmt a))+ , Data (GRHS a (Located body))+ ) => ToHie (LGRHS a (Located body)) where+ toHie (L span g) = concatM $ makeNode g span : case g of+ GRHS _ guards body ->+ [ toHie $ listScopes (mkLScope body) guards+ , toHie body+ ]+ XGRHS _ -> []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , HasType (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (LGRHS a (LHsExpr a))+ , ToHie (RContext (HsRecordBinds a))+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+ , ToHie (ArithSeqInfo a)+ , ToHie (LHsCmdTop a)+ , ToHie (RScoped (GuardLStmt a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+ , Data (HsExpr a)+ , Data (HsSplice a)+ , Data (HsTupArg a)+ , Data (AmbiguousFieldOcc a)+ , (HasRealDataConName a)+ ) => 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) ->+ [ pure $ 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 @a 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+ ]+ HsSCC _ _ _ expr ->+ [ toHie expr+ ]+ HsCoreAnn _ _ _ 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+ ]+ HsTickPragma _ _ _ _ expr ->+ [ toHie expr+ ]+ HsWrap _ _ a ->+ [ toHie $ L mspan a+ ]+ HsBracket _ b ->+ [ toHie b+ ]+ HsRnBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsTcBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsSpliceE _ x ->+ [ toHie $ L mspan x+ ]+ XExpr _ -> []++instance ( a ~ GhcPass p+ , ToHie (LHsExpr a)+ , Data (HsTupArg a)+ ) => ToHie (LHsTupArg (GhcPass p)) where+ toHie (L span arg) = concatM $ makeNode arg span : case arg of+ Present _ expr ->+ [ toHie expr+ ]+ Missing _ -> []+ XTupArg _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (RScoped (ApplicativeArg a))+ , ToHie (Located body)+ , Data (StmtLR a a (Located body))+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : 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+ ]+ XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsLocalBinds a)+ ) => ToHie (RScoped (LHsLocalBinds a)) where+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+ EmptyLocalBinds _ -> []+ HsIPBinds _ _ -> []+ HsValBinds _ valBinds ->+ [ toHie $ RS (combineScopes scope $ mkScope sp)+ valBinds+ ]+ XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (XXValBindsLR a a))+ ) => ToHie (RScoped (HsValBindsLR a a)) 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 ToHie (RScoped (NHsValBindsLR GhcTc)) 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 (RScoped (NHsValBindsLR GhcRn)) 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 (RContext (LHsRecField a arg))+ ) => ToHie (RContext (HsRecFields a arg)) where+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+ , ToHie arg+ , HasLoc arg+ , Data label+ , Data arg+ ) => 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)+ ]+ XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of+ FieldOcc var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XFieldOcc _ -> []++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 _ ->+ [ ]+ XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+ Unambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ Ambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (StmtLR a a (Located (HsExpr a)))+ , Data (HsLocalBinds a)+ ) => 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+ ]+ toHie (RS _ (XApplicativeArg _)) = pure []++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 ( ToHie (LHsCmd a)+ , Data (HsCmdTop a)+ ) => ToHie (LHsCmdTop a) where+ toHie (L span top) = concatM $ makeNode top span : case top of+ HsCmdTop _ cmd ->+ [ toHie cmd+ ]+ XCmdTop _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (MatchGroup a (LHsCmd a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsCmd a)+ , Data (HsCmdTop a)+ , Data (StmtLR a a (Located (HsCmd a)))+ , Data (HsLocalBinds a)+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => 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+ ]+ HsCmdIf _ _ a b c ->+ [ toHie a+ , toHie b+ , toHie c+ ]+ HsCmdLet _ binds cmd' ->+ [ toHie $ RS (mkLScope cmd') binds+ , toHie cmd'+ ]+ HsCmdDo _ (L ispan stmts) ->+ [ pure $ locOnly ispan+ , toHie $ listScopes NoScope stmts+ ]+ HsCmdWrap _ _ _ -> []+ 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+ ]+ toHie (XTyClGroup _) = pure []++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 (pure . 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]+ XTyClDecl _ -> []++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+ XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+ toHie (ClosedTypeFamily (Just eqns)) = concatM $+ [ concatMapM (pure . 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+ ]+ XFamilyResultSig _ -> []++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)+ toHie (XFamEqn _) = pure []++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+ ]+ toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+ toHie (L span clauses) = concatM+ [ pure $ 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+ , pure $ locOnly ispan+ , toHie $ map (TS (ResolvedScopes [])) tys+ ]+ XHsDerivingClause _ -> []++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 _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ ConDeclGADT { con_names = names, con_qvars = qvars+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+ , toHie ctx+ , toHie args+ , toHie typ+ ]+ where+ rhsScope = combineScopes argsScope tyScope+ ctxScope = maybe NoScope mkLScope ctx+ argsScope = condecl_scope args+ tyScope = mkLScope typ+ 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+ XConDecl _ -> []+ where condecl_scope args = case args of+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+ RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+ toHie (L span decls) = concatM $+ [ pure $ locOnly span+ , toHie decls+ ]++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+ toHie (TS sc (HsIB ibrn a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+ toHie (TS sc (HsWC names a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsWildCardBndrs _)) = pure []++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+ ]+ XStandaloneKindSig _ -> []++instance ToHie (SigContext (LSig GhcRn)) where+ toHie (SC (SI styp msp) (L sp sig)) = 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+ , pure $ maybe [] (locOnly . getLoc) mtxt+ ]+ CompleteMatchSig _ _ (L ispan names) typ ->+ [ pure $ locOnly ispan+ , toHie $ map (C Use) names+ , toHie $ fmap (C Use) typ+ ]+ XSig _ -> []++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 _ _ bndrs body ->+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) 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 _ a b ->+ [ 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) = pure $ locOnly sp++instance ToHie (TVScoped (LHsTyVarBndr 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+ ]+ XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+ toHie (TS sc (HsQTvs implicits vars)) = concatM $+ [ pure $ bindingsOnly bindings+ , toHie $ tvScopes sc NoScope vars+ ]+ where+ varLoc = loc vars+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+ toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+ toHie (L span tys) = concatM $+ [ pure $ 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+ ]+ XConDeclField _ -> []++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+ ]+ XSpliceDecl _ -> []++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 ( ToHie (LHsExpr a)+ , Data (HsSplice a)+ ) => ToHie (Located (HsSplice a)) where+ toHie (L span sp) = concatM $ makeNode sp span : case sp of+ HsTypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsUntypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsQuasiQuote _ _ _ ispan _ ->+ [ pure $ locOnly ispan+ ]+ HsSpliced _ _ _ ->+ []+ HsSplicedT _ ->+ []+ XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+ toHie (L span annot) = concatM $ makeNode annot span : case annot of+ RoleAnnotDecl _ var roles ->+ [ toHie $ C Use var+ , concatMapM (pure . locOnly . getLoc) roles+ ]+ XRoleAnnotDecl _ -> []++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+ ]+ XInstDecl _ -> []++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+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+ , toHie $ cid_tyfam_insts decl+ , pure $ concatMap (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+ ]+ XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+ toHie (L span sig) = concatM $ makeNode sig span : case sig of+ FixitySig _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ DefaultDecl _ typs ->+ [ toHie typs+ ]+ XDefaultDecl _ -> []++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+ ]+ XForeignDecl _ -> []++instance ToHie ForeignImport where+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ , locOnly c+ ]++instance ToHie ForeignExport where+ toHie (CExport (L a _) (L b _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ ]++instance ToHie (LWarnDecls GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warnings _ _ warnings ->+ [ toHie warnings+ ]+ XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warning _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ HsAnnotation _ _ prov expr ->+ [ toHie prov+ , toHie expr+ ]+ XAnnDecl _ -> []++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+ ]+ XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+ toHie (L _ (XRuleDecl _)) = pure []+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM+ [ makeNode r span+ , pure $ 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+ ]+ XRuleBndr _ -> []++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+ ]+ XImportDecl _ -> []+ where+ goIE (hiding, (L sp liens)) = concatM $+ [ pure $ 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 _ _ -> []+ XIE _ -> []++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+ ]
+ src-ghc810/Compat/HieBin.hs view
@@ -0,0 +1,399 @@+{-+Binary serialization for .hie files.+-}+{- HLINT ignore -}+{-# LANGUAGE ScopedTypeVariables #-}+module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where++import GHC.Settings ( maybeRead )++import Config ( cProjectVersion )+import Binary+import BinIface ( getDictFastString )+import FastMutInt+import FastString ( FastString )+import Module ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply ( takeUniqFromSupply )+import Unique+import UniqFM+import IfaceEnv++import qualified Data.Array as A+import Data.IORef+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List ( mapAccumR )+import Data.Word ( Word8, Word32 )+import Control.Monad ( replicateM, when )+import System.Directory ( createDirectoryIfMissing )+import System.FilePath ( takeDirectory )++import HieTypes++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+ = ExternalName !Module !OccName !SrcSpan+ | LocalName !OccName !SrcSpan+ | KnownKeyName !Unique+ deriving (Eq)++instance Ord HieName where+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+ compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+ -- Not actually non determinstic as it is a KnownKey+ compare ExternalName{} _ = LT+ compare LocalName{} ExternalName{} = GT+ compare LocalName{} _ = LT+ compare KnownKeyName{} _ = GT++instance Outputable HieName where+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u++hieNameOcc :: HieName -> OccName+hieNameOcc (ExternalName _ occ _) = occ+hieNameOcc (LocalName occ _) = occ+hieNameOcc (KnownKeyName u) =+ case lookupKnownKeyName u of+ Just n -> nameOccName n+ Nothing -> pprPanic "hieNameOcc:unknown known-key unique"+ (ppr (unpkUnique u))+++data HieSymbolTable = HieSymbolTable+ { hie_symtab_next :: !FastMutInt+ , hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))+ }++data HieDictionary = HieDictionary+ { hie_dict_next :: !FastMutInt -- The next index to use+ , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+ }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+ mapM_ (putByte bh) $ BS.unpack xs+ putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+ bh0 <- openBinMem initBinMemSize++ -- Write the header: hieHeader followed by the+ -- hieVersion and the GHC version used to generate this file+ mapM_ (putByte bh0) hieMagic+ putBinLine bh0 $ BSC.pack $ show hieVersion+ putBinLine bh0 $ ghcVersion++ -- remember where the dictionary pointer will go+ dict_p_p <- tellBin bh0+ put_ bh0 dict_p_p++ -- remember where the symbol table pointer will go+ symtab_p_p <- tellBin bh0+ put_ bh0 symtab_p_p++ -- Make some intial state+ symtab_next <- newFastMutInt+ writeFastMutInt symtab_next 0+ symtab_map <- newIORef emptyUFM+ let hie_symtab = HieSymbolTable {+ hie_symtab_next = symtab_next,+ hie_symtab_map = symtab_map }+ dict_next_ref <- newFastMutInt+ writeFastMutInt dict_next_ref 0+ dict_map_ref <- newIORef emptyUFM+ let hie_dict = HieDictionary {+ hie_dict_next = dict_next_ref,+ hie_dict_map = dict_map_ref }++ -- put the main thing+ let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+ (putName hie_symtab)+ (putFastString hie_dict)+ put_ bh hiefile++ -- write the symtab pointer at the front of the file+ symtab_p <- tellBin bh+ putAt bh symtab_p_p symtab_p+ seekBin bh symtab_p++ -- write the symbol table itself+ symtab_next' <- readFastMutInt symtab_next+ symtab_map' <- readIORef symtab_map+ putSymbolTable bh symtab_next' symtab_map'++ -- write the dictionary pointer at the front of the file+ dict_p <- tellBin bh+ putAt bh dict_p_p dict_p+ seekBin bh dict_p++ -- write the dictionary itself+ dict_next <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+ putDictionary bh dict_next dict_map++ -- and send the result to the file+ createDirectoryIfMissing True (takeDirectory hie_file_path)+ writeBinMem bh hie_file_path+ return ()++data HieFileResult+ = HieFileResult+ { hie_file_result_version :: Integer+ , hie_file_result_ghc_version :: ByteString+ , hie_file_result :: HieFile+ }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion ncu file = do+ bh0 <- readBinMem file++ (hieVersion, ghcVersion) <- readHieFileHeader file bh0++ if readVersion (hieVersion, ghcVersion)+ then do+ hieFile <- readHieFileContents bh0 ncu+ return $ Right (HieFileResult hieVersion ghcVersion hieFile)+ else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult+readHieFile ncu file = do++ bh0 <- readBinMem file++ (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++ -- Check if the versions match+ when (readHieVersion /= hieVersion) $+ panic $ unwords ["readHieFile: hie file versions don't match for file:"+ , file+ , "Expected"+ , show hieVersion+ , "but got", show readHieVersion+ ]+ hieFile <- readHieFileContents bh0 ncu+ return $ HieFileResult hieVersion ghcVersion hieFile++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+ where+ loop acc = do+ char <- get bh :: IO Word8+ if char == 10 -- ASCII newline '\n'+ then return acc+ else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+ -- Read the header+ magic <- replicateM hieMagicLen (get bh0)+ version <- BSC.unpack <$> readBinLine bh0+ case maybeRead version of+ Nothing ->+ panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+ , show version+ ]+ Just readHieVersion -> do+ ghcVersion <- readBinLine bh0++ -- Check if the header is valid+ when (magic /= hieMagic) $+ panic $ unwords ["readHieFileHeader: headers don't match for file:"+ , file+ , "Expected"+ , show hieMagic+ , "but got", show magic+ ]+ return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile+readHieFileContents bh0 ncu = do++ dict <- get_dictionary bh0++ -- read the symbol table so we are capable of reading the actual data+ bh1 <- do+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+ (getDictFastString dict)+ symtab <- get_symbol_table bh1+ let bh1' = setUserData bh1+ $ newReadState (getSymTabName symtab)+ (getDictFastString dict)+ return bh1'++ -- load the actual data+ hiefile <- get bh1+ return hiefile+ where+ get_dictionary bin_handle = do+ dict_p <- get bin_handle+ data_p <- tellBin bin_handle+ seekBin bin_handle dict_p+ dict <- getDictionary bin_handle+ seekBin bin_handle data_p+ return dict++ get_symbol_table bh1 = do+ symtab_p <- get bh1+ data_p' <- tellBin bh1+ seekBin bh1 symtab_p+ symtab <- getSymbolTable bh1 ncu+ seekBin bh1 data_p'+ return symtab++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+ hie_dict_map = out_r} bh f+ = do+ out <- readIORef out_r+ let unique = getUnique f+ case lookupUFM out unique of+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)+ Nothing -> do+ j <- readFastMutInt j_r+ put_ bh (fromIntegral j :: Word32)+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+ put_ bh next_off+ let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+ mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+ sz <- get bh+ od_names <- replicateM sz (getHieName bh)+ updateNameCache ncu $ \nc ->+ let arr = A.listArray (0,sz-1) names+ (nc', names) = mapAccumR fromHieName nc od_names+ in (nc',arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+ i :: Word32 <- get bh+ return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+ symmap <- readIORef ref+ case lookupUFM symmap name of+ Just (off, ExternalName mod occ (UnhelpfulSpan _))+ | isGoodSrcSpan (nameSrcSpan name) -> do+ let hieName = ExternalName mod occ (nameSrcSpan name)+ writeIORef ref $! addToUFM symmap name (off, hieName)+ put_ bh (fromIntegral off :: Word32)+ Just (off, LocalName _occ span)+ | notLocal (toHieName name) || nameSrcSpan name /= span -> do+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)+ Just (off, _) -> put_ bh (fromIntegral off :: Word32)+ Nothing -> do+ off <- readFastMutInt next+ writeFastMutInt next (off+1)+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)++ where+ notLocal :: HieName -> Bool+ notLocal LocalName{} = False+ notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+ | isKnownKeyName name = KnownKeyName (nameUnique name)+ | isExternalName name = ExternalName (nameModule name)+ (nameOccName name)+ (nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+ let cache = nsNames nc+ in case lookupOrigNameCache cache mod occ of+ Just name+ | nameSrcSpan name == span -> (nc, name)+ | otherwise ->+ let name' = setNameLoc name span+ new_cache = extendNameCache cache mod occ name'+ in ( nc{ nsNames = new_cache }, name' )+ Nothing ->+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkExternalName uniq mod occ span+ new_cache = extendNameCache cache mod occ name+ in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkInternalName uniq occ span+ in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+ Nothing -> pprPanic "fromHieName:unknown known-key unique"+ (ppr (unpkUnique u))+ Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+ putByte bh 0+ put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+ putByte bh 1+ put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+ putByte bh 2+ put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+ t <- getByte bh+ case t of+ 0 -> do+ (modu, occ, span) <- get bh+ return $ ExternalName modu occ span+ 1 -> do+ (occ, span) <- get bh+ return $ LocalName occ span+ 2 -> do+ (c,i) <- get bh+ return $ KnownKeyName $ mkUnique c i+ _ -> panic "HieBin.getHieName: invalid tag"
+ src-ghc86/Compat/HieAst.hs view
@@ -0,0 +1,1783 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile++Main functions for .hie file generation+-}+{- HLINT ignore -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+module Compat.HieAst ( mkHieFile, enrichHie ) where++import Avail ( Avails )+import Bag ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class ( FunDep )+import CoreUtils ( exprType )+import ConLike ( conLikeName )+import Desugar ( deSugarExpr )+import FieldLabel+import HsSyn+import HscTypes+import Module ( ModuleName, ml_hs_file )+import MonadUtils ( concatMapM, liftIO )+import Name ( Name, nameSrcSpan )+import SrcLoc+import TcHsSyn ( hsLitType, hsPatType )+import Type ( mkFunTys, Type )+import TysWiredIn ( mkListTy, mkSumTy )+import Var ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface ( mkIfaceExports )++import Compat.HieTypes+import Compat.HieUtils++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 (foldl', foldl1' )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class ( lift )++-- These synonyms match those defined in main/GHC.hs+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]+ , Maybe [(LIE GhcRn, Avails)]+ , Maybe LHsDocString )+type TypecheckedSource = LHsBinds GhcTc++-- | Marks that a field uses the GhcRn variant even when the pass+-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because+-- HsType GhcTc should never occur.+type family NoGhcTc (p :: *) where+ -- this way, GHC can figure out that the result is a GhcPass+ NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)+ NoGhcTc other = other++type family NoGhcTcPass (p :: Pass) :: Pass where+ NoGhcTcPass 'Typechecked = 'Renamed+ NoGhcTcPass other = other++{- 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.+-}+newtype HieState = HieState+ { name_remapping :: M.Map Name Id+ }++initState :: HieState+initState = HieState M.empty++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 = M.insert (varName mono) poly (name_remapping hs)}++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 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 tc_binds = tcg_binds ts+ (asts', arr) <- getCompressedAsts tc_binds rs+ let Just src_file = ml_hs_file $ ms_location ms+ 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+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+ asts <- enrichHie ts rs+ return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ 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+ let spanFile children = case children of+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+ (realSrcSpanEnd $ nodeSpan $ last children)++ modulify xs =+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++ asts = HieASTs+ $ resolveTyVarScopes+ $ M.map (modulify . mergeSortAsts)+ $ M.fromListWith (++)+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++ flat_asts = concat+ [ tasts+ , rasts+ , imps+ , exps+ ]+ 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 _) = error "XGRHS has no span"++bindingsOnly :: [Context Name] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+ info = mempty{identInfo = S.singleton c}+ _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local tranformation, 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 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 a]+ -> [TVScoped (LHsTyVarBndr 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+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explictly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+ GhcRn+ (Shielded (LHsType GhcRn)))+ ProtectedSig GhcTc = NoExt++class ProtectSig a where+ protectSig :: Scope -> XSigPat a -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+ loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+ protectSig _ _ = NoExt++instance ProtectSig GhcRn where+ protectSig sc (HsWC a (HsIB b sig)) =+ HsWC a (HsIB b (SH sc sig))+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"++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+ loc _ = noSrcSpan++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 b) => HasLoc (FamEqn s a b) where+ loc (FamEqn _ a b _ c) = foldl1' combineSrcSpans [loc a, 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+ loc _ = noSrcSpan++-- | The main worker class+class ToHie a where+ toHie :: a -> HieM [HieAST Type]++-- | Used to collect type info+class Data a => 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 (Context (Located NoExt)) where+ toHie _ = pure []++instance ToHie (TScoped NoExt) where+ toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+ toHie (IEC c (L (RealSrcSpan span) mname)) =+ pure $ [Node (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')+ -> do+ m <- asks name_remapping+ let name = M.findWithDefault name' (varName name') m+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right $ varName name)+ (IdentifierDetails (Just $ varType name')+ (S.singleton context)))+ span+ []]+ _ -> pure []++instance ToHie (Context (Located Name)) where+ toHie c = case c of+ C context (L (RealSrcSpan span) name') -> do+ m <- asks name_remapping+ let name = case M.lookup name' m of+ Just var -> varName var+ Nothing -> name'+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right name)+ (IdentifierDetails Nothing+ (S.singleton context)))+ span+ []]+ _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped Type) where+ toHie _ = pure []++instance HasType (LHsBind GhcRn) where+ getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+ getTypeNode (L spn bind) = case bind of+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+ _ -> makeNode bind spn++instance HasType (LPat GhcRn) where+ getTypeNode (L spn pat) = makeNode pat spn++instance HasType (LPat GhcTc) where+ getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+ getTypeNode (L spn e) = makeNode e spn++-- | 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 HasType (LHsExpr GhcTc) where+ getTypeNode e@(L spn e') = lift $+ -- Some expression forms have their type immediately available+ let tyOpt = case e' of+ HsLit _ l -> Just (hsLitType l)+ HsOverLit _ o -> Just (overLitType o)++ 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+ _ | skipDesugaring e' -> fallback+ | otherwise -> do+ hs_env <- 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) = mkFunTys 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 a -> Bool+ skipDesugaring e = case e of+ HsVar{} -> False+ HsUnboundVar{} -> False+ HsConLikeOut{} -> False+ HsRecFld{} -> False+ HsOverLabel{} -> False+ HsIPVar{} -> False+ HsWrap{} -> False+ _ -> True++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a (LHsExpr a))+ , ToHie (LHsExpr a)+ , ToHie (Located (PatSynBind a a))+ , HasType (LHsBind a)+ , ModifyState (IdP a)+ , Data (HsBind a)+ ) => ToHie (BindContext (LHsBind a)) where+ toHie (BC context scope b@(L span bind)) =+ concatM $ getTypeNode b : case bind of+ FunBind{fun_id = name, fun_matches = matches} ->+ [ toHie $ C (ValBind context scope $ getRealSpan span) name+ , toHie matches+ ]+ 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} ->+ [ local (modifyState xs) $ -- Note [Name Remapping]+ toHie $ fmap (BC context scope) binds+ ]+ PatSynBind _ psb ->+ [ toHie $ L span psb -- PatSynBinds only occur at the top level+ ]+ XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+ ) => ToHie (MatchGroup a body) where+ toHie mg = concatM $ case mg of+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+ [ pure $ locOnly span+ , toHie alts+ ]+ MG{} -> []+ XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (HsPatSynDir a)+ ) => ToHie (Located (PatSynBind a a)) 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 NoScope pat+ , toHie dir+ ]+ where+ lhsScope = combineScopes varScope detScope+ varScope = mkLScope var+ 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+ XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+ ) => ToHie (HsPatSynDir a) where+ toHie dir = case dir of+ ExplicitBidirectional mg -> toHie mg+ _ -> pure []++instance ( a ~ GhcPass p+ , ToHie body+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a body)+ , Data (Match a body)+ ) => ToHie (LMatch (GhcPass p) body) where+ toHie (L span m ) = concatM $ makeNode m span : 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+ ]+ XMatch _ -> []++instance ( ToHie (Context (Located a))+ ) => ToHie (HsMatchContext a) where+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+ toHie (StmtCtxt a) = toHie a+ toHie _ = pure []++instance ( ToHie (HsMatchContext a)+ ) => ToHie (HsStmtContext a) where+ toHie (PatGuard a) = toHie a+ toHie (ParStmtCtxt a) = toHie a+ toHie (TransStmtCtxt a) = toHie a+ toHie _ = pure []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+ , ToHie (LHsExpr a)+ , ToHie (TScoped (LHsSigWcType a))+ , ProtectSig a+ , ToHie (TScoped (ProtectedSig a))+ , HasType (LPat a)+ , Data (HsSplice a)+ ) => ToHie (PScoped (LPat (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+ ]+ ConPatIn c dets ->+ [ toHie $ C Use c+ , toHie $ contextify dets+ ]+ ConPatOut {pat_con = con, pat_args = dets}->+ [ toHie $ C Use $ fmap conLikeName 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 sig pat ->+ [ toHie $ PS rsp scope pscope pat+ , let cscope = mkLScope pat in+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])+ (protectSig @a cscope sig)+ -- See Note [Scoping Rules for SigPat]+ ]+ CoPat _ _ _ _ ->+ []+ XPat _ -> []+ where+ 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 body+ , ToHie (LGRHS a body)+ , ToHie (RScoped (LHsLocalBinds a))+ ) => ToHie (GRHSs a body) where+ toHie grhs = concatM $ case grhs of+ GRHSs _ grhss binds ->+ [ toHie grhss+ , toHie $ RS (mkScope $ grhss_span grhs) binds+ ]+ XGRHSs _ -> []++instance ( ToHie (Located body)+ , ToHie (RScoped (GuardLStmt a))+ , Data (GRHS a (Located body))+ ) => ToHie (LGRHS a (Located body)) where+ toHie (L span g) = concatM $ makeNode g span : case g of+ GRHS _ guards body ->+ [ toHie $ listScopes (mkLScope body) guards+ , toHie body+ ]+ XGRHS _ -> []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , HasType (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (LGRHS a (LHsExpr a))+ , ToHie (RContext (HsRecordBinds a))+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+ , ToHie (ArithSeqInfo a)+ , ToHie (LHsCmdTop a)+ , ToHie (RScoped (GuardLStmt a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+ , ToHie (TScoped (XExprWithTySig (GhcPass p)))+ , ToHie (TScoped (XAppTypeE (GhcPass p)))+ , Data (HsExpr a)+ , Data (HsSplice a)+ , Data (HsTupArg a)+ , Data (AmbiguousFieldOcc a)+ ) => 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 sig expr ->+ [ 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) ->+ [ pure $ locOnly ispan+ , toHie $ listScopes NoScope stmts+ ]+ ExplicitList _ _ exprs ->+ [ toHie exprs+ ]+ RecordCon {rcon_con_name = name, rcon_flds = binds}->+ [ toHie $ C Use name+ , toHie $ RC RecFieldAssign $ binds+ ]+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->+ [ toHie expr+ , toHie $ map (RC RecFieldAssign) upds+ ]+ ExprWithTySig sig expr ->+ [ toHie expr+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig+ ]+ ArithSeq _ _ info ->+ [ toHie info+ ]+ HsSCC _ _ _ expr ->+ [ toHie expr+ ]+ HsCoreAnn _ _ _ expr ->+ [ toHie expr+ ]+ HsProc _ pat cmdtop ->+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+ , toHie cmdtop+ ]+ HsStatic _ expr ->+ [ toHie expr+ ]+ HsArrApp _ a b _ _ ->+ [ toHie a+ , toHie b+ ]+ HsArrForm _ expr _ cmds ->+ [ toHie expr+ , toHie cmds+ ]+ HsTick _ _ expr ->+ [ toHie expr+ ]+ HsBinTick _ _ _ expr ->+ [ toHie expr+ ]+ HsTickPragma _ _ _ _ expr ->+ [ toHie expr+ ]+ HsWrap _ _ a ->+ [ toHie $ L mspan a+ ]+ HsBracket _ b ->+ [ toHie b+ ]+ HsRnBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsTcBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsSpliceE _ x ->+ [ toHie $ L mspan x+ ]+ EWildPat _ -> []+ EAsPat _ a b ->+ [ toHie $ C Use a+ , toHie b+ ]+ EViewPat _ a b ->+ [ toHie a+ , toHie b+ ]+ ELazyPat _ a ->+ [ toHie a+ ]+ XExpr _ -> []++instance ( a ~ GhcPass p+ , ToHie (LHsExpr a)+ , Data (HsTupArg a)+ ) => ToHie (LHsTupArg (GhcPass p)) where+ toHie (L span arg) = concatM $ makeNode arg span : case arg of+ Present _ expr ->+ [ toHie expr+ ]+ Missing _ -> []+ XTupArg _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (RScoped (ApplicativeArg a))+ , ToHie (Located body)+ , Data (StmtLR a a (Located body))+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : 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+ ]+ XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsLocalBinds a)+ ) => ToHie (RScoped (LHsLocalBinds a)) where+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+ EmptyLocalBinds _ -> []+ HsIPBinds _ _ -> []+ HsValBinds _ valBinds ->+ [ toHie $ RS (combineScopes scope $ mkScope sp)+ valBinds+ ]+ XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (XXValBindsLR a a))+ ) => ToHie (RScoped (HsValBindsLR a a)) 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 ToHie (RScoped (NHsValBindsLR GhcTc)) 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 (RScoped (NHsValBindsLR GhcRn)) 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 (RContext (LHsRecField a arg))+ ) => ToHie (RContext (HsRecFields a arg)) where+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+ , ToHie arg+ , HasLoc arg+ , Data label+ , Data arg+ ) => 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)+ ]+ XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of+ FieldOcc var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XFieldOcc _ -> []++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 _ ->+ [ ]+ XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+ Unambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ Ambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (StmtLR a a (Located (HsExpr a)))+ , Data (HsLocalBinds a)+ ) => 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+ ]+ toHie (RS _ (XApplicativeArg _)) = pure []++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 ( ToHie (LHsCmd a)+ , Data (HsCmdTop a)+ ) => ToHie (LHsCmdTop a) where+ toHie (L span top) = concatM $ makeNode top span : case top of+ HsCmdTop _ cmd ->+ [ toHie cmd+ ]+ XCmdTop _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (MatchGroup a (LHsCmd a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsCmd a)+ , Data (HsCmdTop a)+ , Data (StmtLR a a (Located (HsCmd a)))+ , Data (HsLocalBinds a)+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => 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+ ]+ HsCmdIf _ _ a b c ->+ [ toHie a+ , toHie b+ , toHie c+ ]+ HsCmdLet _ binds cmd' ->+ [ toHie $ RS (mkLScope cmd') binds+ , toHie cmd'+ ]+ HsCmdDo _ (L ispan stmts) ->+ [ pure $ locOnly ispan+ , toHie $ listScopes NoScope stmts+ ]+ HsCmdWrap _ _ _ -> []+ XCmd _ -> []++instance ToHie (TyClGroup GhcRn) where+ toHie (TyClGroup _ classes roles instances) = concatM+ [ toHie classes+ , toHie roles+ , toHie instances+ ]+ toHie (XTyClGroup _) = pure []++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 (pure . locOnly . getLoc) deftyps+ , toHie $ map (go . unLoc) deftyps+ ]+ where+ context_scope = mkLScope context+ rhs_scope = foldl1' combineScopes $ map mkScope+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]++ go :: TyFamDefltEqn GhcRn+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)+ go (FamEqn a var pat b rhs) =+ FamEqn a var (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs+ go (XFamEqn NoExt) = XFamEqn NoExt+ XTyClDecl _ -> []++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+ XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+ toHie (ClosedTypeFamily (Just eqns)) = concatM $+ [ concatMapM (pure . 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+ ]+ XFamilyResultSig _ -> []++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 pats, ToHie rhs, HasLoc pats, HasLoc rhs)+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where+ toHie (TS _ f) = toHie f++instance ( ToHie pats+ , ToHie rhs+ , HasLoc pats+ , HasLoc rhs+ ) => ToHie (FamEqn GhcRn pats rhs) where+ toHie fe@(FamEqn _ var pats _ rhs) = concatM $+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+ , toHie pats+ , toHie rhs+ ]+ toHie (XFamEqn _) = pure []++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+ ]+ toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+ toHie (L span clauses) = concatM+ [ pure $ 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+ , pure $ locOnly ispan+ , toHie $ map (TS (ResolvedScopes [])) tys+ ]+ XHsDerivingClause _ -> []++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 _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ ConDeclGADT { con_names = names, con_qvars = qvars+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+ , toHie ctx+ , toHie args+ , toHie typ+ ]+ where+ rhsScope = combineScopes argsScope tyScope+ ctxScope = maybe NoScope mkLScope ctx+ argsScope = condecl_scope args+ tyScope = mkLScope typ+ 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+ XConDecl _ -> []+ where condecl_scope args = case args of+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+ RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+ toHie (L span decls) = concatM $+ [ pure $ locOnly span+ , toHie decls+ ]++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+ toHie (TS sc (HsIB ibrn a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) $ (hsib_vars ibrn)+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+ toHie (TS sc (HsWC names a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (SigContext (LSig GhcRn)) where+ toHie (SC (SI styp msp) (L sp sig)) = 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+ , pure $ maybe [] (locOnly . getLoc) mtxt+ ]+ CompleteMatchSig _ _ (L ispan names) typ ->+ [ pure $ locOnly ispan+ , toHie $ map (C Use) names+ , toHie $ fmap (C Use) typ+ ]+ XSig _ -> []++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 _ bndrs body ->+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs+ , toHie body+ ]+ HsQualTy _ ctx body ->+ [ toHie ctx+ , toHie body+ ]+ HsTyVar _ _ var ->+ [ toHie $ C Use var+ ]+ HsAppTy _ a b ->+ [ toHie a+ , toHie b+ ]+ HsFunTy _ a b ->+ [ 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) = pure $ locOnly sp+-}++instance ToHie (TVScoped (LHsTyVarBndr 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+ ]+ XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $+ [ pure $ bindingsOnly bindings+ , toHie $ tvScopes sc NoScope vars+ ]+ where+ varLoc = loc vars+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+ toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+ toHie (L span tys) = concatM $+ [ pure $ 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+ ]+ XConDeclField _ -> []++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+ ]+ XSpliceDecl _ -> []++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 ( ToHie (LHsExpr a)+ , Data (HsSplice a)+ ) => ToHie (Located (HsSplice a)) where+ toHie (L span sp) = concatM $ makeNode sp span : case sp of+ HsTypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsUntypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsQuasiQuote _ _ _ ispan _ ->+ [ pure $ locOnly ispan+ ]+ HsSpliced _ _ _ ->+ []+ XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+ toHie (L span annot) = concatM $ makeNode annot span : case annot of+ RoleAnnotDecl _ var roles ->+ [ toHie $ C Use var+ , concatMapM (pure . locOnly . getLoc) roles+ ]+ XRoleAnnotDecl _ -> []++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+ ]+ XInstDecl _ -> []++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+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+ , toHie $ cid_tyfam_insts decl+ , pure $ concatMap (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+ ]+ XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+ toHie (L span sig) = concatM $ makeNode sig span : case sig of+ FixitySig _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ DefaultDecl _ typs ->+ [ toHie typs+ ]+ XDefaultDecl _ -> []++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+ ]+ XForeignDecl _ -> []++instance ToHie ForeignImport where+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ , locOnly c+ ]++instance ToHie ForeignExport where+ toHie (CExport (L a _) (L b _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ ]++instance ToHie (LWarnDecls GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warnings _ _ warnings ->+ [ toHie warnings+ ]+ XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warning _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ HsAnnotation _ _ prov expr ->+ [ toHie prov+ , toHie expr+ ]+ XAnnDecl _ -> []++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+ ]+ XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+ toHie (L _ (XRuleDecl _)) = pure []+ toHie (L span r@(HsRule _ rname _ bndrs exprA exprB)) = concatM+ [ makeNode r span+ , pure $ locOnly $ getLoc rname+ , toHie $ map (RS $ mkScope span) bndrs+ , toHie exprA+ , toHie 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+ ]+ XRuleBndr _ -> []++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+ ]+ XImportDecl _ -> []+ where+ goIE (hiding, (L sp liens)) = concatM $+ [ pure $ 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 _ _ -> []+ XIE _ -> []++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+ ]+
+ src-ghc86/Compat/HieBin.hs view
@@ -0,0 +1,388 @@+{-+Binary serialization for .hie files.+-}+{-# LANGUAGE ScopedTypeVariables #-}+module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where++import Config ( cProjectVersion )+import Binary+import BinIface ( getDictFastString )+import FastMutInt+import FastString ( FastString )+import Module ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply ( takeUniqFromSupply )+import Util ( maybeRead )+import Unique+import UniqFM+import IfaceEnv++import qualified Data.Array as A+import Data.IORef+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List ( mapAccumR )+import Data.Word ( Word8, Word32 )+import Control.Monad ( replicateM, when )+import System.Directory ( createDirectoryIfMissing )+import System.FilePath ( takeDirectory )++import Compat.HieTypes++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+ = ExternalName !Module !OccName !SrcSpan+ | LocalName !OccName !SrcSpan+ | KnownKeyName !Unique+ deriving (Eq)++instance Ord HieName where+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+ compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+ -- Not actually non determinstic as it is a KnownKey+ compare ExternalName{} _ = LT+ compare LocalName{} ExternalName{} = GT+ compare LocalName{} _ = LT+ compare KnownKeyName{} _ = GT++instance Outputable HieName where+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u+++data HieSymbolTable = HieSymbolTable+ { hie_symtab_next :: !FastMutInt+ , hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))+ }++data HieDictionary = HieDictionary+ { hie_dict_next :: !FastMutInt -- The next index to use+ , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+ }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+ mapM_ (putByte bh) $ BS.unpack xs+ putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+ bh0 <- openBinMem initBinMemSize++ -- Write the header: hieHeader followed by the+ -- hieVersion and the GHC version used to generate this file+ mapM_ (putByte bh0) hieMagic+ putBinLine bh0 $ BSC.pack $ show hieVersion+ putBinLine bh0 $ ghcVersion++ -- remember where the dictionary pointer will go+ dict_p_p <- tellBin bh0+ put_ bh0 dict_p_p++ -- remember where the symbol table pointer will go+ symtab_p_p <- tellBin bh0+ put_ bh0 symtab_p_p++ -- Make some intial state+ symtab_next <- newFastMutInt+ writeFastMutInt symtab_next 0+ symtab_map <- newIORef emptyUFM+ let hie_symtab = HieSymbolTable {+ hie_symtab_next = symtab_next,+ hie_symtab_map = symtab_map }+ dict_next_ref <- newFastMutInt+ writeFastMutInt dict_next_ref 0+ dict_map_ref <- newIORef emptyUFM+ let hie_dict = HieDictionary {+ hie_dict_next = dict_next_ref,+ hie_dict_map = dict_map_ref }++ -- put the main thing+ let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+ (putName hie_symtab)+ (putFastString hie_dict)+ put_ bh hiefile++ -- write the symtab pointer at the front of the file+ symtab_p <- tellBin bh+ putAt bh symtab_p_p symtab_p+ seekBin bh symtab_p++ -- write the symbol table itself+ symtab_next' <- readFastMutInt symtab_next+ symtab_map' <- readIORef symtab_map+ putSymbolTable bh symtab_next' symtab_map'++ -- write the dictionary pointer at the front of the file+ dict_p <- tellBin bh+ putAt bh dict_p_p dict_p+ seekBin bh dict_p++ -- write the dictionary itself+ dict_next <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+ putDictionary bh dict_next dict_map++ -- and send the result to the file+ createDirectoryIfMissing True (takeDirectory hie_file_path)+ writeBinMem bh hie_file_path+ return ()++data HieFileResult+ = HieFileResult+ { hie_file_result_version :: Integer+ , hie_file_result_ghc_version :: ByteString+ , hie_file_result :: HieFile+ }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion ncu file = do+ bh0 <- readBinMem file++ (hieVersion, ghcVersion) <- readHieFileHeader file bh0++ if readVersion (hieVersion, ghcVersion)+ then do+ hieFile <- readHieFileContents bh0 ncu+ return $ Right (HieFileResult hieVersion ghcVersion hieFile)+ else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult+readHieFile ncu file = do++ bh0 <- readBinMem file++ (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++ -- Check if the versions match+ when (readHieVersion /= hieVersion) $+ panic $ unwords ["readHieFile: hie file versions don't match for file:"+ , file+ , "Expected"+ , show hieVersion+ , "but got", show readHieVersion+ ]+ hieFile <- readHieFileContents bh0 ncu+ return $ HieFileResult hieVersion ghcVersion hieFile++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+ where+ loop acc = do+ char <- get bh :: IO Word8+ if char == 10 -- ASCII newline '\n'+ then return acc+ else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+ -- Read the header+ magic <- replicateM hieMagicLen (get bh0)+ version <- BSC.unpack <$> readBinLine bh0+ case maybeRead version of+ Nothing ->+ panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+ , show version+ ]+ Just readHieVersion -> do+ ghcVersion <- readBinLine bh0++ -- Check if the header is valid+ when (magic /= hieMagic) $+ panic $ unwords ["readHieFileHeader: headers don't match for file:"+ , file+ , "Expected"+ , show hieMagic+ , "but got", show magic+ ]+ return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile+readHieFileContents bh0 ncu = do++ dict <- get_dictionary bh0++ -- read the symbol table so we are capable of reading the actual data+ bh1 <- do+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+ (getDictFastString dict)+ symtab <- get_symbol_table bh1+ let bh1' = setUserData bh1+ $ newReadState (getSymTabName symtab)+ (getDictFastString dict)+ return bh1'++ -- load the actual data+ hiefile <- get bh1+ return hiefile+ where+ get_dictionary bin_handle = do+ dict_p <- get bin_handle+ data_p <- tellBin bin_handle+ seekBin bin_handle dict_p+ dict <- getDictionary bin_handle+ seekBin bin_handle data_p+ return dict++ get_symbol_table bh1 = do+ symtab_p <- get bh1+ data_p' <- tellBin bh1+ seekBin bh1 symtab_p+ symtab <- getSymbolTable bh1 ncu+ seekBin bh1 data_p'+ return symtab++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+ hie_dict_map = out_r} bh f+ = do+ out <- readIORef out_r+ let unique = getUnique f+ case lookupUFM out unique of+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)+ Nothing -> do+ j <- readFastMutInt j_r+ put_ bh (fromIntegral j :: Word32)+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+ put_ bh next_off+ let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+ mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+ sz <- get bh+ od_names <- replicateM sz (getHieName bh)+ updateNameCache ncu $ \nc ->+ let arr = A.listArray (0,sz-1) names+ (nc', names) = mapAccumR fromHieName nc od_names+ in (nc',arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+ i :: Word32 <- get bh+ return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+ symmap <- readIORef ref+ case lookupUFM symmap name of+ Just (off, ExternalName mod occ (UnhelpfulSpan _))+ | isGoodSrcSpan (nameSrcSpan name) -> do+ let hieName = ExternalName mod occ (nameSrcSpan name)+ writeIORef ref $! addToUFM symmap name (off, hieName)+ put_ bh (fromIntegral off :: Word32)+ Just (off, LocalName _occ span)+ | notLocal (toHieName name) || nameSrcSpan name /= span -> do+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)+ Just (off, _) -> put_ bh (fromIntegral off :: Word32)+ Nothing -> do+ off <- readFastMutInt next+ writeFastMutInt next (off+1)+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)++ where+ notLocal :: HieName -> Bool+ notLocal LocalName{} = False+ notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+ | isKnownKeyName name = KnownKeyName (nameUnique name)+ | isExternalName name = ExternalName (nameModule name)+ (nameOccName name)+ (nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+ let cache = nsNames nc+ in case lookupOrigNameCache cache mod occ of+ Just name+ | nameSrcSpan name == span -> (nc, name)+ | otherwise ->+ let name' = setNameLoc name span+ new_cache = extendNameCache cache mod occ name'+ in ( nc{ nsNames = new_cache }, name' )+ Nothing ->+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkExternalName uniq mod occ span+ new_cache = extendNameCache cache mod occ name+ in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkInternalName uniq occ span+ in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+ Nothing -> pprPanic "fromHieName:unknown known-key unique"+ (ppr (unpkUnique u))+ Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+ putByte bh 0+ put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+ putByte bh 1+ put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+ putByte bh 2+ put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+ t <- getByte bh+ case t of+ 0 -> do+ (modu, occ, span) <- get bh+ return $ ExternalName modu occ span+ 1 -> do+ (occ, span) <- get bh+ return $ LocalName occ span+ 2 -> do+ (c,i) <- get bh+ return $ KnownKeyName $ mkUnique c i+ _ -> panic "HieBin.getHieName: invalid tag"
+ src-ghc86/Compat/HieDebug.hs view
@@ -0,0 +1,145 @@+{-+Functions to validate and check .hie file ASTs generated by GHC.+-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Compat.HieDebug where++import Prelude hiding ((<>))+import SrcLoc+import Module+import FastString+import Outputable++import Compat.HieTypes+import Compat.HieBin+import Compat.HieUtils++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Function ( on )+import Data.List ( sortOn )+import Data.Foldable ( toList )++ppHies :: Outputable a => (HieASTs a) -> SDoc+ppHies (HieASTs asts) = M.foldrWithKey go "" asts+ where+ go k a rest = vcat $+ [ "File: " <> ppr k+ , ppHie a+ , rest+ ]++ppHie :: Outputable a => HieAST a -> SDoc+ppHie = go 0+ where+ go n (Node inf sp children) = hang header n rest+ where+ rest = vcat $ map (go (n+2)) children+ header = hsep+ [ "Node"+ , ppr sp+ , ppInfo inf+ ]++ppInfo :: Outputable a => NodeInfo a -> SDoc+ppInfo ni = hsep+ [ ppr $ toList $ nodeAnnotations ni+ , ppr $ nodeType ni+ , ppr $ M.toList $ nodeIdentifiers ni+ ]++type Diff a = a -> a -> [SDoc]++diffFile :: Diff HieFile+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)++diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts f = diffList (diffAst f) `on` M.elems++diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)+diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =+ infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2+ where+ spanDiff+ | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]+ | otherwise = []+ infoDiff+ = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2+ ++ (diffList diffType `on` nodeType) info1 info2+ ++ (diffIdents `on` nodeIdentifiers) info1 info2+ diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b+ diffIdent (a,b) (c,d) = diffName a c+ ++ eqDiff b d+ diffName (Right a) (Right b) = case (a,b) of+ (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')+ (LocalName o _, ExternalName _ o' _) -> eqDiff o o'+ _ -> eqDiff a b+ diffName a b = eqDiff a b++type DiffIdent = Either ModuleName HieName++normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn fst . map (first toHieName) . M.toList+ where+ first f (a,b) = (fmap f a, b)++diffList :: Diff a -> Diff [a]+diffList f xs ys+ | length xs == length ys = concat $ zipWith f xs ys+ | otherwise = ["length of lists doesn't match"]++eqDiff :: (Outputable a, Eq a) => Diff a+eqDiff a b+ | a == b = []+ | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]++validAst :: HieAST a -> Either SDoc ()+validAst (Node _ span children) = do+ checkContainment children+ checkSorted children+ mapM_ validAst children+ where+ checkSorted [] = return ()+ checkSorted [_] = return ()+ checkSorted (x:y:xs)+ | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)+ | otherwise = Left $ hsep+ [ ppr $ nodeSpan x+ , "is not to the left of"+ , ppr $ nodeSpan y+ ]+ checkContainment [] = return ()+ checkContainment (x:xs)+ | span `containsSpan` (nodeSpan x) = checkContainment xs+ | otherwise = Left $ hsep+ [ ppr $ span+ , "does not contain"+ , ppr $ nodeSpan x+ ]++-- | Look for any identifiers which occur outside of their supposed scopes.+-- Returns a list of error messages.+validateScopes :: M.Map FastString (HieAST a) -> [SDoc]+validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+ where+ refMap = generateReferencesMap asts+ valid (Left _) _ = []+ valid (Right n) refs = concatMap inScope refs+ where+ mapRef = foldMap getScopeFromContext . identInfo . snd+ scopes = case foldMap mapRef refs of+ Just xs -> xs+ Nothing -> []+ inScope (sp, dets)+ | definedInAsts asts n+ && any isOccurrence (identInfo dets)+ = case scopes of+ [] -> []+ _ -> if any (`scopeContainsSpan` sp) scopes+ then []+ else return $ hsep $+ [ "Name", ppr n, "at position", ppr sp+ , "doesn't occur in calculated scope", ppr scopes]+ | otherwise = []
+ src-ghc86/Compat/HieTypes.hs view
@@ -0,0 +1,534 @@+{-+Types for the .hie file format are defined here.++For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files+-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Compat.HieTypes where++import Config+import Binary+import FastString ( FastString )+import IfaceType+import Module ( ModuleName, Module )+import Name ( Name )+import Outputable hiding ( (<>) )+import SrcLoc+import Avail++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.Set as S+import Data.ByteString ( ByteString )+import Data.Data ( Typeable, Data )+import Data.Semigroup ( Semigroup(..) )+import Data.Word ( Word8 )+import Control.Applicative ( (<|>) )++type Span = RealSrcSpan++instance Binary RealSrcSpan where+ put_ bh ss = do+ put_ bh (srcSpanFile ss)+ put_ bh (srcSpanStartLine ss)+ put_ bh (srcSpanStartCol ss)+ put_ bh (srcSpanEndLine ss)+ put_ bh (srcSpanEndCol ss)++ get bh = do+ f <- get bh+ sl <- get bh+ sc <- get bh+ el <- get bh+ ec <- get bh+ return (mkRealSrcSpan (mkRealSrcLoc f sl sc)+ (mkRealSrcLoc f el ec))++instance (A.Ix a, Binary a, Binary b) => Binary (A.Array a b) where+ put_ bh arr = do+ put_ bh $ A.bounds arr+ put_ bh $ A.elems arr+ get bh = do+ bounds <- get bh+ xs <- get bh+ return $ A.listArray bounds xs++-- | Current version of @.hie@ files+hieVersion :: Integer+hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer++{- |+GHC builds up a wealth of information about Haskell source as it compiles it.+@.hie@ files are a way of persisting some of this information to disk so that+external tools that need to work with haskell source don't need to parse,+typecheck, and rename all over again. These files contain:++ * a simplified AST++ * nodes are annotated with source positions and types+ * identifiers are annotated with scope information++ * the raw bytes of the initial Haskell source++Besides saving compilation cycles, @.hie@ files also offer a more stable+interface than the GHC API.+-}+data HieFile = HieFile+ { hie_hs_file :: FilePath+ -- ^ Initial Haskell source file path++ , hie_module :: Module+ -- ^ The module this HIE file is for++ , hie_types :: A.Array TypeIndex HieTypeFlat+ -- ^ Types referenced in the 'hie_asts'.+ --+ -- See Note [Efficient serialization of redundant type info]++ , hie_asts :: HieASTs TypeIndex+ -- ^ Type-annotated abstract syntax trees++ , hie_exports :: [AvailInfo]+ -- ^ The names that this module exports++ , hie_hs_src :: ByteString+ -- ^ Raw bytes of the initial Haskell source+ }+instance Binary HieFile where+ put_ bh hf = do+ put_ bh $ hie_hs_file hf+ put_ bh $ hie_module hf+ put_ bh $ hie_types hf+ put_ bh $ hie_asts hf+ put_ bh $ hie_exports hf+ put_ bh $ hie_hs_src hf++ get bh = HieFile+ <$> get bh+ <*> get bh+ <*> get bh+ <*> get bh+ <*> get bh+ <*> get bh+++{-+Note [Efficient serialization of redundant type info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The type information in .hie files is highly repetitive and redundant. For+example, consider the expression++ const True 'a'++There is a lot of shared structure between the types of subterms:++ * const True 'a' :: Bool+ * const True :: Char -> Bool+ * const :: Bool -> Char -> Bool++Since all 3 of these types need to be stored in the .hie file, it is worth+making an effort to deduplicate this shared structure. The trick is to define+a new data type that is a flattened version of 'Type':++ data HieType a = HAppTy a a -- data Type = AppTy Type Type+ | HFunTy a a -- | FunTy Type Type+ | ...++ type TypeIndex = Int++Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',+where the 'TypeIndex's in the 'HieType' are references to other elements of the+array. Types recovered from GHC are deduplicated and stored in this compressed+form with sharing of subtrees.+-}++type TypeIndex = Int++-- | A flattened version of 'Type'.+--+-- See Note [Efficient serialization of redundant type info]+data HieType a+ = HTyVarTy Name+ | HAppTy a a+ | HTyConApp IfaceTyCon (HieArgs a)+ | HForAllTy ((Name, a),ArgFlag) a+ | HFunTy a a+ | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')+ | HLitTy IfaceTyLit+ | HCastTy a+ | HCoercionTy+ deriving (Functor, Foldable, Traversable, Eq)++type HieTypeFlat = HieType TypeIndex++-- | Roughly isomorphic to the original core 'Type'.+newtype HieTypeFix = Roll (HieType (HieTypeFix))++instance Binary (HieType TypeIndex) where+ put_ bh (HTyVarTy n) = do+ putByte bh 0+ put_ bh n+ put_ bh (HAppTy a b) = do+ putByte bh 1+ put_ bh a+ put_ bh b+ put_ bh (HTyConApp n xs) = do+ putByte bh 2+ put_ bh n+ put_ bh xs+ put_ bh (HForAllTy bndr a) = do+ putByte bh 3+ put_ bh bndr+ put_ bh a+ put_ bh (HFunTy a b) = do+ putByte bh 4+ put_ bh a+ put_ bh b+ put_ bh (HQualTy a b) = do+ putByte bh 5+ put_ bh a+ put_ bh b+ put_ bh (HLitTy l) = do+ putByte bh 6+ put_ bh l+ put_ bh (HCastTy a) = do+ putByte bh 7+ put_ bh a+ put_ bh (HCoercionTy) = putByte bh 8++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> HTyVarTy <$> get bh+ 1 -> HAppTy <$> get bh <*> get bh+ 2 -> HTyConApp <$> get bh <*> get bh+ 3 -> HForAllTy <$> get bh <*> get bh+ 4 -> HFunTy <$> get bh <*> get bh+ 5 -> HQualTy <$> get bh <*> get bh+ 6 -> HLitTy <$> get bh+ 7 -> HCastTy <$> get bh+ 8 -> return HCoercionTy+ _ -> panic "Binary (HieArgs Int): invalid tag"+++-- | A list of type arguments along with their respective visibilities (ie. is+-- this an argument that would return 'True' for 'isVisibleArgFlag'?).+newtype HieArgs a = HieArgs [(Bool,a)]+ deriving (Functor, Foldable, Traversable, Eq)++instance Binary (HieArgs TypeIndex) where+ put_ bh (HieArgs xs) = put_ bh xs+ get bh = HieArgs <$> get bh++-- | Mapping from filepaths (represented using 'FastString') to the+-- corresponding AST+newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }+ deriving (Functor, Foldable, Traversable)++instance Binary (HieASTs TypeIndex) where+ put_ bh asts = put_ bh $ M.toAscList $ getAsts asts+ get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)+++data HieAST a =+ Node+ { nodeInfo :: NodeInfo a+ , nodeSpan :: Span+ , nodeChildren :: [HieAST a]+ } deriving (Functor, Foldable, Traversable)++instance Binary (HieAST TypeIndex) where+ put_ bh ast = do+ put_ bh $ nodeInfo ast+ put_ bh $ nodeSpan ast+ put_ bh $ nodeChildren ast++ get bh = Node+ <$> get bh+ <*> get bh+ <*> get bh+++-- | The information stored in one AST node.+--+-- The type parameter exists to provide flexibility in representation of types+-- (see Note [Efficient serialization of redundant type info]).+data NodeInfo a = NodeInfo+ { nodeAnnotations :: S.Set (FastString,FastString)+ -- ^ (name of the AST node constructor, name of the AST node Type)++ , nodeType :: [a]+ -- ^ The Haskell types of this node, if any.++ , nodeIdentifiers :: NodeIdentifiers a+ -- ^ All the identifiers and their details+ } deriving (Functor, Foldable, Traversable)++instance Binary (NodeInfo TypeIndex) where+ put_ bh ni = do+ put_ bh $ S.toAscList $ nodeAnnotations ni+ put_ bh $ nodeType ni+ put_ bh $ M.toList $ nodeIdentifiers ni+ get bh = NodeInfo+ <$> fmap (S.fromDistinctAscList) (get bh)+ <*> get bh+ <*> fmap (M.fromList) (get bh)++type Identifier = Either ModuleName Name++type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)++-- | Information associated with every identifier+--+-- We need to include types with identifiers because sometimes multiple+-- identifiers occur in the same span(Overloaded Record Fields and so on)+data IdentifierDetails a = IdentifierDetails+ { identType :: Maybe a+ , identInfo :: S.Set ContextInfo+ } deriving (Eq, Functor, Foldable, Traversable)++instance Outputable a => Outputable (IdentifierDetails a) where+ ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)++instance Semigroup (IdentifierDetails a) where+ d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)+ (S.union (identInfo d1) (identInfo d2))++instance Monoid (IdentifierDetails a) where+ mempty = IdentifierDetails Nothing S.empty++instance Binary (IdentifierDetails TypeIndex) where+ put_ bh dets = do+ put_ bh $ identType dets+ put_ bh $ S.toAscList $ identInfo dets+ get bh = IdentifierDetails+ <$> get bh+ <*> fmap (S.fromDistinctAscList) (get bh)+++-- | Different contexts under which identifiers exist+data ContextInfo+ = Use -- ^ regular variable+ | MatchBind+ | IEThing IEType -- ^ import/export+ | TyDecl++ -- | Value binding+ | ValBind+ BindType -- ^ whether or not the binding is in an instance+ Scope -- ^ scope over which the value is bound+ (Maybe Span) -- ^ span of entire binding++ -- | Pattern binding+ --+ -- This case is tricky because the bound identifier can be used in two+ -- distinct scopes. Consider the following example (with @-XViewPatterns@)+ --+ -- @+ -- do (b, a, (a -> True)) <- bar+ -- foo a+ -- @+ --+ -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and+ -- in the rest of the @do@-block in @foo a@.+ | PatternBind+ Scope -- ^ scope /in the pattern/ (the variable bound can be used+ -- further in the pattern)+ Scope -- ^ rest of the scope outside the pattern+ (Maybe Span) -- ^ span of entire binding++ | ClassTyDecl (Maybe Span)++ -- | Declaration+ | Decl+ DeclType -- ^ type of declaration+ (Maybe Span) -- ^ span of entire binding++ -- | Type variable+ | TyVarBind Scope TyVarScope++ -- | Record field+ | RecField RecFieldContext (Maybe Span)+ deriving (Eq, Ord, Show)++instance Outputable ContextInfo where+ ppr = text . show++instance Binary ContextInfo where+ put_ bh Use = putByte bh 0+ put_ bh (IEThing t) = do+ putByte bh 1+ put_ bh t+ put_ bh TyDecl = putByte bh 2+ put_ bh (ValBind bt sc msp) = do+ putByte bh 3+ put_ bh bt+ put_ bh sc+ put_ bh msp+ put_ bh (PatternBind a b c) = do+ putByte bh 4+ put_ bh a+ put_ bh b+ put_ bh c+ put_ bh (ClassTyDecl sp) = do+ putByte bh 5+ put_ bh sp+ put_ bh (Decl a b) = do+ putByte bh 6+ put_ bh a+ put_ bh b+ put_ bh (TyVarBind a b) = do+ putByte bh 7+ put_ bh a+ put_ bh b+ put_ bh (RecField a b) = do+ putByte bh 8+ put_ bh a+ put_ bh b+ put_ bh MatchBind = putByte bh 9++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> return Use+ 1 -> IEThing <$> get bh+ 2 -> return TyDecl+ 3 -> ValBind <$> get bh <*> get bh <*> get bh+ 4 -> PatternBind <$> get bh <*> get bh <*> get bh+ 5 -> ClassTyDecl <$> get bh+ 6 -> Decl <$> get bh <*> get bh+ 7 -> TyVarBind <$> get bh <*> get bh+ 8 -> RecField <$> get bh <*> get bh+ 9 -> return MatchBind+ _ -> panic "Binary ContextInfo: invalid tag"+++-- | Types of imports and exports+data IEType+ = Import+ | ImportAs+ | ImportHiding+ | Export+ deriving (Eq, Enum, Ord, Show)++instance Binary IEType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data RecFieldContext+ = RecFieldDecl+ | RecFieldAssign+ | RecFieldMatch+ | RecFieldOcc+ deriving (Eq, Enum, Ord, Show)++instance Binary RecFieldContext where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data BindType+ = RegularBind+ | InstanceBind+ deriving (Eq, Ord, Show, Enum)++instance Binary BindType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data DeclType+ = FamDec -- ^ type or data family+ | SynDec -- ^ type synonym+ | DataDec -- ^ data declaration+ | ConDec -- ^ constructor declaration+ | PatSynDec -- ^ pattern synonym+ | ClassDec -- ^ class declaration+ | InstDec -- ^ instance declaration+ deriving (Eq, Ord, Show, Enum)++instance Binary DeclType where+ put_ bh b = putByte bh (fromIntegral (fromEnum b))+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data Scope+ = NoScope+ | LocalScope Span+ | ModuleScope+ deriving (Eq, Ord, Show, Typeable, Data)++instance Outputable Scope where+ ppr NoScope = text "NoScope"+ ppr (LocalScope sp) = text "LocalScope" <+> ppr sp+ ppr ModuleScope = text "ModuleScope"++instance Binary Scope where+ put_ bh NoScope = putByte bh 0+ put_ bh (LocalScope span) = do+ putByte bh 1+ put_ bh span+ put_ bh ModuleScope = putByte bh 2++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> return NoScope+ 1 -> LocalScope <$> get bh+ 2 -> return ModuleScope+ _ -> panic "Binary Scope: invalid tag"+++-- | Scope of a type variable.+--+-- This warrants a data type apart from 'Scope' because of complexities+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For+-- example, consider:+--+-- @+-- foo, bar, baz :: forall a. a -> a+-- @+--+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we+-- need a list of scopes to keep track of this. Furthermore, this list cannot be+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.+--+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@+-- which later gets resolved into a 'ResolvedScopes'.+data TyVarScope+ = ResolvedScopes [Scope]++ -- | Unresolved scopes should never show up in the final @.hie@ file+ | UnresolvedScope+ [Name] -- ^ names of the definitions over which the scope spans+ (Maybe Span) -- ^ the location of the instance/class declaration for+ -- the case where the type variable is declared in a+ -- method type signature+ deriving (Eq, Ord)++instance Show TyVarScope where+ show (ResolvedScopes sc) = show sc+ show _ = error "UnresolvedScope"++instance Binary TyVarScope where+ put_ bh (ResolvedScopes xs) = do+ putByte bh 0+ put_ bh xs+ put_ bh (UnresolvedScope ns span) = do+ putByte bh 1+ put_ bh ns+ put_ bh span++ get bh = do+ (t :: Word8) <- get bh+ case t of+ 0 -> ResolvedScopes <$> get bh+ 1 -> UnresolvedScope <$> get bh <*> get bh+ _ -> panic "Binary TyVarScope: invalid tag"
+ src-ghc86/Compat/HieUtils.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module Compat.HieUtils where++import CoreMap+import DynFlags ( DynFlags )+import FastString ( FastString, mkFastString )+import IfaceType+import Name hiding (varName)+import Outputable ( renderWithStyle, ppr, defaultUserStyle )+import SrcLoc+import ToIface+import TyCon+import TyCoRep+import Type+import Var+import VarEnv++import Compat.HieTypes++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap.Strict as IM+import qualified Data.Array as A+import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )+import Data.Maybe ( maybeToList )+import Data.Monoid+import Data.Traversable ( for )+import Control.Monad.Trans.State.Strict hiding (get)+++generateReferencesMap+ :: Foldable f+ => f (HieAST a)+ -> M.Map Identifier [(Span, IdentifierDetails a)]+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty+ where+ go ast = M.unionsWith (++) (this : map go (nodeChildren ast))+ where+ this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast++renderHieType :: DynFlags -> HieTypeFix -> String+renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty+ where sty = defaultUserStyle df++resolveVisibility :: Type -> [Type] -> [(Bool,Type)]+resolveVisibility kind ty_args+ = go (mkEmptyTCvSubst in_scope) kind ty_args+ where+ in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++ go _ _ [] = []+ go env ty ts+ | Just ty' <- coreView ty+ = go env ty' ts+ go env (ForAllTy (TvBndr tv vis) res) (t:ts)+ | isVisibleArgFlag vis = (True , t) : ts'+ | otherwise = (False, t) : ts'+ where+ ts' = go (extendTvSubst env tv t) res ts++ go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps+ = (True,t) : (go env res ts)++ go env (TyVarTy tv) ts+ | Just ki <- lookupTyVar env tv = go env ki ts+ go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded++foldType :: (HieType a -> a) -> HieTypeFix -> a+foldType f (Roll t) = f $ fmap (foldType f) t++hieTypeToIface :: HieTypeFix -> IfaceType+hieTypeToIface = foldType go+ where+ go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n+ go (HAppTy a b) = IfaceAppTy a b+ go (HLitTy l) = IfaceLitTy l+ go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)+ in IfaceForAllTy (TvBndr b af) t+ go (HFunTy a b) = IfaceFunTy a b+ go (HQualTy pred b) = IfaceDFunTy pred b+ go (HCastTy a) = a+ go HCoercionTy = IfaceTyVar "<coercion type>"+ go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)++ -- This isn't fully faithful - we can't produce the 'Inferred' case+ hieToIfaceArgs :: HieArgs IfaceType -> IfaceTcArgs+ hieToIfaceArgs (HieArgs xs) = go' xs+ where+ go' [] = ITC_Nil+ go' ((True ,x):xs) = ITC_Vis x $ go' xs+ go' ((False,x):xs) = ITC_Invis x $ go' xs++data HieTypeState+ = HTS+ { tyMap :: !(TypeMap TypeIndex)+ , htyTable :: !(IM.IntMap HieTypeFlat)+ , freshIndex :: !TypeIndex+ }++initialHTS :: HieTypeState+initialHTS = HTS emptyTypeMap IM.empty 0++freshTypeIndex :: State HieTypeState TypeIndex+freshTypeIndex = do+ index <- gets freshIndex+ modify' $ \hts -> hts { freshIndex = index+1 }+ return index++compressTypes+ :: HieASTs Type+ -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+compressTypes asts = (a, arr)+ where+ (a, (HTS _ m i)) = flip runState initialHTS $+ for asts $ \typ -> do+ i <- getTypeIndex typ+ return i+ arr = A.array (0,i-1) (IM.toList m)++recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix+recoverFullType i m = go i+ where+ go i = Roll $ fmap go (m A.! i)++getTypeIndex :: Type -> State HieTypeState TypeIndex+getTypeIndex t+ | otherwise = do+ tm <- gets tyMap+ case lookupTypeMap tm t of+ Just i -> return i+ Nothing -> do+ ht <- go t+ extendHTS t ht+ where+ extendHTS t ht = do+ i <- freshTypeIndex+ modify' $ \(HTS tm tt fi) ->+ HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi+ return i++ go (TyVarTy v) = return $ HTyVarTy $ varName v+ go (AppTy a b) = do+ ai <- getTypeIndex a+ bi <- getTypeIndex b+ return $ HAppTy ai bi+ go (TyConApp f xs) = do+ let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs+ is <- mapM getTypeIndex visArgs+ return $ HTyConApp (toIfaceTyCon f) is+ go (ForAllTy (TvBndr v a) t) = do+ k <- getTypeIndex (varType v)+ i <- getTypeIndex t+ return $ HForAllTy ((varName v,k),a) i+ go (FunTy a b) = do+ ai <- getTypeIndex a+ bi <- getTypeIndex b+ return $ if isPredTy a+ then HQualTy ai bi+ else HFunTy ai bi+ go (LitTy a) = return $ HLitTy $ toIfaceTyLit a+ go (CastTy t _) = do+ i <- getTypeIndex t+ return $ HCastTy i+ go (CoercionTy _) = return HCoercionTy++resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)+resolveTyVarScopes asts = M.map go asts+ where+ go ast = resolveTyVarScopeLocal ast asts++resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a+resolveTyVarScopeLocal ast asts = go ast+ where+ resolveNameScope dets = dets{identInfo =+ S.map resolveScope (identInfo dets)}+ resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =+ TyVarBind sc $ ResolvedScopes+ [ LocalScope binding+ | name <- names+ , Just binding <- [getNameBinding name asts]+ ]+ resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =+ TyVarBind sc $ ResolvedScopes+ [ LocalScope binding+ | name <- names+ , Just binding <- [getNameBindingInClass name sp asts]+ ]+ resolveScope scope = scope+ go (Node info span children) = Node info' span $ map go children+ where+ info' = info { nodeIdentifiers = idents }+ idents = M.map resolveNameScope $ nodeIdentifiers info++getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span+getNameBinding n asts = do+ (_,msp) <- getNameScopeAndBinding n asts+ msp++getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]+getNameScope n asts = do+ (scopes,_) <- getNameScopeAndBinding n asts+ return scopes++getNameBindingInClass+ :: Name+ -> Span+ -> M.Map FastString (HieAST a)+ -> Maybe Span+getNameBindingInClass n sp asts = do+ ast <- M.lookup (srcSpanFile sp) asts+ getFirst $ foldMap First $ do+ child <- flattenAst ast+ dets <- maybeToList+ $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child+ let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+ return (getFirst binding)++getNameScopeAndBinding+ :: Name+ -> M.Map FastString (HieAST a)+ -> Maybe ([Scope], Maybe Span)+getNameScopeAndBinding n asts = case nameSrcSpan n of+ RealSrcSpan sp -> do -- @Maybe+ ast <- M.lookup (srcSpanFile sp) asts+ defNode <- selectLargestContainedBy sp ast+ getFirst $ foldMap First $ do -- @[]+ node <- flattenAst defNode+ dets <- maybeToList+ $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node+ scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)+ let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+ return $ Just (scopes, getFirst binding)+ _ -> Nothing++getScopeFromContext :: ContextInfo -> Maybe [Scope]+getScopeFromContext (ValBind _ sc _) = Just [sc]+getScopeFromContext (PatternBind a b _) = Just [a, b]+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]+getScopeFromContext (Decl _ _) = Just [ModuleScope]+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs+getScopeFromContext (TyVarBind a _) = Just [a]+getScopeFromContext _ = Nothing++getBindSiteFromContext :: ContextInfo -> Maybe Span+getBindSiteFromContext (ValBind _ _ sp) = sp+getBindSiteFromContext (PatternBind _ _ sp) = sp+getBindSiteFromContext _ = Nothing++flattenAst :: HieAST a -> [HieAST a]+flattenAst n =+ n : concatMap flattenAst (nodeChildren n)++smallestContainingSatisfying+ :: Span+ -> (HieAST a -> Bool)+ -> HieAST a+ -> Maybe (HieAST a)+smallestContainingSatisfying sp cond node+ | nodeSpan node `containsSpan` sp = getFirst $ mconcat+ [ foldMap (First . smallestContainingSatisfying sp cond) $+ nodeChildren node+ , First $ if cond node then Just node else Nothing+ ]+ | sp `containsSpan` nodeSpan node = Nothing+ | otherwise = Nothing++selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)+selectLargestContainedBy sp node+ | sp `containsSpan` nodeSpan node = Just node+ | nodeSpan node `containsSpan` sp =+ getFirst $ foldMap (First . selectLargestContainedBy sp) $+ nodeChildren node+ | otherwise = Nothing++selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)+selectSmallestContaining sp node+ | nodeSpan node `containsSpan` sp = getFirst $ mconcat+ [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node+ , First (Just node)+ ]+ | sp `containsSpan` nodeSpan node = Nothing+ | otherwise = Nothing++definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool+definedInAsts asts n = case nameSrcSpan n of+ RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts+ _ -> False++isOccurrence :: ContextInfo -> Bool+isOccurrence Use = True+isOccurrence _ = False++scopeContainsSpan :: Scope -> Span -> Bool+scopeContainsSpan NoScope _ = False+scopeContainsSpan ModuleScope _ = True+scopeContainsSpan (LocalScope a) b = a `containsSpan` b++-- | One must contain the other. Leaf nodes cannot contain anything+combineAst :: HieAST Type -> HieAST Type -> HieAST Type+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)+ | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)+ | aSpn `containsSpan` bSpn = combineAst b a+combineAst a (Node xs span children) = Node xs span (insertAst a children)++-- | Insert an AST in a sorted list of disjoint Asts+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]+insertAst x = mergeAsts [x]++-- | Merge two nodes together.+--+-- Precondition and postcondition: elements in 'nodeType' are ordered.+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =+ NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+ where+ mergeSorted :: [Type] -> [Type] -> [Type]+ mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of+ LT -> a : mergeSorted as lb+ EQ -> a : mergeSorted as bs+ GT -> b : mergeSorted la bs+ mergeSorted as [] = as+ mergeSorted [] bs = bs+++{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.++In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),+different nodes in an AST tree should either have disjoint spans (in+which case you can say for sure which one comes first) or one span+should be completely contained in the other (in which case the contained+span corresponds to some child node).++However, since Haskell does have position-altering pragmas it /is/+possible for spans to be overlapping. Here is an example of a source file+in which @foozball@ and @quuuuuux@ have overlapping spans:++@+module Baz where++# line 3 "Baz.hs"+foozball :: Int+foozball = 0++# line 3 "Baz.hs"+bar, quuuuuux :: Int+bar = 1+quuuuuux = 2+@++In these cases, we just do our best to produce sensible `HieAST`'s. The blame+should be laid at the feet of whoever wrote the line pragmas in the first place+(usually the C preprocessor...).+-}+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]+mergeAsts xs [] = xs+mergeAsts [] ys = ys+mergeAsts xs@(a:as) ys@(b:bs)+ | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs+ | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs)+ | span_a `rightOf` span_b = b : mergeAsts xs bs+ | span_a `leftOf` span_b = a : mergeAsts as ys++ -- These cases are to work around ASTs that are not fully disjoint+ | span_a `startsRightOf` span_b = b : mergeAsts as ys+ | otherwise = a : mergeAsts as ys+ where+ span_a = nodeSpan a+ span_b = nodeSpan b++rightOf :: Span -> Span -> Bool+rightOf s1 s2+ = (srcSpanStartLine s1, srcSpanStartCol s1)+ >= (srcSpanEndLine s2, srcSpanEndCol s2)+ && (srcSpanFile s1 == srcSpanFile s2)++leftOf :: Span -> Span -> Bool+leftOf s1 s2+ = (srcSpanEndLine s1, srcSpanEndCol s1)+ <= (srcSpanStartLine s2, srcSpanStartCol s2)+ && (srcSpanFile s1 == srcSpanFile s2)++startsRightOf :: Span -> Span -> Bool+startsRightOf s1 s2+ = (srcSpanStartLine s1, srcSpanStartCol s1)+ >= (srcSpanStartLine s2, srcSpanStartCol s2)++-- | combines and sorts ASTs using a merge sort+mergeSortAsts :: [HieAST Type] -> [HieAST Type]+mergeSortAsts = go . map pure+ where+ go [] = []+ go [xs] = xs+ go xss = go (mergePairs xss)+ mergePairs [] = []+ mergePairs [xs] = [xs]+ mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss++simpleNodeInfo :: FastString -> FastString -> NodeInfo a+simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty++locOnly :: SrcSpan -> [HieAST a]+locOnly (RealSrcSpan span) =+ [Node e span []]+ where e = NodeInfo S.empty [] M.empty+locOnly _ = []++mkScope :: SrcSpan -> Scope+mkScope (RealSrcSpan sp) = LocalScope sp+mkScope _ = NoScope++mkLScope :: Located a -> Scope+mkLScope = mkScope . getLoc++combineScopes :: Scope -> Scope -> Scope+combineScopes ModuleScope _ = ModuleScope+combineScopes _ ModuleScope = ModuleScope+combineScopes NoScope x = x+combineScopes x NoScope = x+combineScopes (LocalScope a) (LocalScope b) =+ mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)++{-# INLINEABLE makeNode #-}+makeNode+ :: (Applicative m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> SrcSpan -- ^ return an empty list if this is unhelpful+ -> m [HieAST b]+makeNode x spn = pure $ case spn of+ RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]+ _ -> []+ where+ cons = mkFastString . show . toConstr $ x+ typ = mkFastString . show . typeRepTyCon . typeOf $ x++{-# INLINEABLE makeTypeNode #-}+makeTypeNode+ :: (Applicative m, Data a)+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')+ -> SrcSpan -- ^ return an empty list if this is unhelpful+ -> Type -- ^ type to associate with the node+ -> m [HieAST Type]+makeTypeNode x spn etyp = pure $ case spn of+ RealSrcSpan span ->+ [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]+ _ -> []+ where+ cons = mkFastString . show . toConstr $ x+ typ = mkFastString . show . typeRepTyCon . typeOf $ x
+ src-ghc88/Compat/HieAst.hs view
@@ -0,0 +1,1786 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile++Main functions for .hie file generation+-}+{- HLINT ignore -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Compat.HieAst ( mkHieFile, enrichHie ) where++import Avail ( Avails )+import Bag ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class ( FunDep )+import CoreUtils ( exprType )+import ConLike ( conLikeName )+import Desugar ( deSugarExpr )+import FieldLabel+import HsSyn+import HscTypes+import Module ( ModuleName, ml_hs_file )+import MonadUtils ( concatMapM, liftIO )+import Name ( Name, nameSrcSpan )+import SrcLoc+import TcHsSyn ( hsLitType, hsPatType )+import Type ( mkFunTys, Type )+import TysWiredIn ( mkListTy, mkSumTy )+import Var ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface ( mkIfaceExports )++import HieTypes+import HieUtils++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 (foldl', foldl1' )+import Data.Maybe ( listToMaybe )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class ( lift )++-- These synonyms match those defined in main/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.+-}+newtype HieState = HieState+ { name_remapping :: M.Map Name Id+ }++initState :: HieState+initState = HieState M.empty++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 = M.insert (varName mono) poly (name_remapping hs)}++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 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 tc_binds = tcg_binds ts+ (asts', arr) <- getCompressedAsts tc_binds rs+ let Just src_file = ml_hs_file $ ms_location ms+ 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+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+ asts <- enrichHie ts rs+ return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ 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+ let spanFile children = case children of+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+ (realSrcSpanEnd $ nodeSpan $ last children)++ modulify xs =+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++ asts = HieASTs+ $ resolveTyVarScopes+ $ M.map (modulify . mergeSortAsts)+ $ M.fromListWith (++)+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++ flat_asts = concat+ [ tasts+ , rasts+ , imps+ , exps+ ]+ 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 _) = error "XGRHS has no span"++bindingsOnly :: [Context Name] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+ info = mempty{identInfo = S.singleton c}+ _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local tranformation, 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 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 (unLoc a)) $+ listScopes patScope (map dL xs)++-- | 'listScopes' specialised to 'TVScoped' things+tvScopes+ :: TyVarScope+ -> Scope+ -> [LHsTyVarBndr a]+ -> [TVScoped (LHsTyVarBndr 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+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explictly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+ GhcRn+ (Shielded (LHsType GhcRn)))+ ProtectedSig GhcTc = NoExt++class ProtectSig a where+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+ loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+ protectSig _ _ = NoExt++instance ProtectSig GhcRn where+ protectSig sc (HsWC a (HsIB b sig)) =+ HsWC a (HsIB b (SH sc sig))+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"++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+ loc _ = noSrcSpan++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 b) => HasLoc (FamEqn s a b) 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+ loc _ = noSrcSpan++instance HasLoc (Pat (GhcPass a)) where+ loc (dL -> L l _) = l++-- | The main worker class+class ToHie a where+ toHie :: a -> HieM [HieAST Type]++-- | Used to collect type info+class Data a => 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 (Context (Located NoExt)) where+ toHie _ = pure []++instance ToHie (TScoped NoExt) where+ toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+ toHie (IEC c (L (RealSrcSpan span) mname)) =+ pure $ [Node (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')+ -> do+ m <- asks name_remapping+ let name = M.findWithDefault name' (varName name') m+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right $ varName name)+ (IdentifierDetails (Just $ varType name')+ (S.singleton context)))+ span+ []]+ _ -> pure []++instance ToHie (Context (Located Name)) where+ toHie c = case c of+ C context (L (RealSrcSpan span) name') -> do+ m <- asks name_remapping+ let name = case M.lookup name' m of+ Just var -> varName var+ Nothing -> name'+ pure+ [Node+ (NodeInfo S.empty [] $+ M.singleton (Right name)+ (IdentifierDetails Nothing+ (S.singleton context)))+ span+ []]+ _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+ toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+ toHie _ = pure []+instance ToHie (TScoped Type) where+ toHie _ = pure []++instance HasType (LHsBind GhcRn) where+ getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+ getTypeNode (L spn bind) = case bind of+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+ _ -> makeNode bind spn++instance HasType (LPat GhcRn) where+ getTypeNode (dL -> L spn pat) = makeNode pat spn++instance HasType (LPat GhcTc) where+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+ getTypeNode (L spn e) = makeNode e spn++-- | 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 HasType (LHsExpr GhcTc) where+ getTypeNode e@(L spn e') = lift $+ -- Some expression forms have their type immediately available+ let tyOpt = case e' of+ HsLit _ l -> Just (hsLitType l)+ HsOverLit _ o -> Just (overLitType o)++ 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+ _ | skipDesugaring e' -> fallback+ | otherwise -> do+ hs_env <- 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) = mkFunTys 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 a -> Bool+ skipDesugaring e = case e of+ HsVar{} -> False+ HsUnboundVar{} -> False+ HsConLikeOut{} -> False+ HsRecFld{} -> False+ HsOverLabel{} -> False+ HsIPVar{} -> False+ HsWrap{} -> False+ _ -> True++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a (LHsExpr a))+ , ToHie (LHsExpr a)+ , ToHie (Located (PatSynBind a a))+ , HasType (LHsBind a)+ , ModifyState (IdP a)+ , Data (HsBind a)+ ) => ToHie (BindContext (LHsBind a)) where+ toHie (BC context scope b@(L span bind)) =+ concatM $ getTypeNode b : case bind of+ FunBind{fun_id = name, fun_matches = matches} ->+ [ toHie $ C (ValBind context scope $ getRealSpan span) name+ , toHie matches+ ]+ 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} ->+ [ local (modifyState xs) $ -- Note [Name Remapping]+ toHie $ fmap (BC context scope) binds+ ]+ PatSynBind _ psb ->+ [ toHie $ L span psb -- PatSynBinds only occur at the top level+ ]+ XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+ ) => ToHie (MatchGroup a body) where+ toHie mg = concatM $ case mg of+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+ [ pure $ locOnly span+ , toHie alts+ ]+ MG{} -> []+ XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (HsPatSynDir a)+ ) => ToHie (Located (PatSynBind a a)) 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 NoScope pat+ , toHie dir+ ]+ where+ lhsScope = combineScopes varScope detScope+ varScope = mkLScope var+ 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+ XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+ ) => ToHie (HsPatSynDir a) where+ toHie dir = case dir of+ ExplicitBidirectional mg -> toHie mg+ _ -> pure []++instance ( a ~ GhcPass p+ , ToHie body+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+ , ToHie (PScoped (LPat a))+ , ToHie (GRHSs a body)+ , Data (Match a body)+ ) => ToHie (LMatch (GhcPass p) body) where+ toHie (L span m ) = concatM $ makeNode m span : 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+ ]+ XMatch _ -> []++instance ( ToHie (Context (Located a))+ ) => ToHie (HsMatchContext a) where+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+ toHie (StmtCtxt a) = toHie a+ toHie _ = pure []++instance ( ToHie (HsMatchContext a)+ ) => ToHie (HsStmtContext a) where+ toHie (PatGuard a) = toHie a+ toHie (ParStmtCtxt a) = toHie a+ toHie (TransStmtCtxt a) = toHie a+ toHie _ = pure []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+ , ToHie (LHsExpr a)+ , ToHie (TScoped (LHsSigWcType a))+ , ProtectSig a+ , ToHie (TScoped (ProtectedSig a))+ , HasType (LPat a)+ , Data (HsSplice a)+ ) => ToHie (PScoped (LPat (GhcPass p))) where+ toHie (PS rsp scope pscope lpat@(dL -> 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 (dL 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+ ]+ ConPatIn c dets ->+ [ toHie $ C Use c+ , toHie $ contextify dets+ ]+ ConPatOut {pat_con = con, pat_args = dets}->+ [ toHie $ C Use $ fmap conLikeName 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+ , let cscope = mkLScope (dL pat) in+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])+ (protectSig @a cscope sig)+ -- See Note [Scoping Rules for SigPat]+ ]+ CoPat _ _ _ _ ->+ []+ XPat _ -> []+ where+ 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 body+ , ToHie (LGRHS a body)+ , ToHie (RScoped (LHsLocalBinds a))+ ) => ToHie (GRHSs a body) where+ toHie grhs = concatM $ case grhs of+ GRHSs _ grhss binds ->+ [ toHie grhss+ , toHie $ RS (mkScope $ grhss_span grhs) binds+ ]+ XGRHSs _ -> []++instance ( ToHie (Located body)+ , ToHie (RScoped (GuardLStmt a))+ , Data (GRHS a (Located body))+ ) => ToHie (LGRHS a (Located body)) where+ toHie (L span g) = concatM $ makeNode g span : case g of+ GRHS _ guards body ->+ [ toHie $ listScopes (mkLScope body) guards+ , toHie body+ ]+ XGRHS _ -> []++instance ( a ~ GhcPass p+ , ToHie (Context (Located (IdP a)))+ , HasType (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (MatchGroup a (LHsExpr a))+ , ToHie (LGRHS a (LHsExpr a))+ , ToHie (RContext (HsRecordBinds a))+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+ , ToHie (ArithSeqInfo a)+ , ToHie (LHsCmdTop a)+ , ToHie (RScoped (GuardLStmt a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+ , Data (HsExpr a)+ , Data (HsSplice a)+ , Data (HsTupArg a)+ , Data (AmbiguousFieldOcc a)+ ) => 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) ->+ [ pure $ locOnly ispan+ , toHie $ listScopes NoScope stmts+ ]+ ExplicitList _ _ exprs ->+ [ toHie exprs+ ]+ RecordCon {rcon_con_name = name, rcon_flds = binds}->+ [ toHie $ C Use 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+ ]+ HsSCC _ _ _ expr ->+ [ toHie expr+ ]+ HsCoreAnn _ _ _ expr ->+ [ toHie expr+ ]+ HsProc _ pat cmdtop ->+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+ , toHie cmdtop+ ]+ HsStatic _ expr ->+ [ toHie expr+ ]+ HsArrApp _ a b _ _ ->+ [ toHie a+ , toHie b+ ]+ HsArrForm _ expr _ cmds ->+ [ toHie expr+ , toHie cmds+ ]+ HsTick _ _ expr ->+ [ toHie expr+ ]+ HsBinTick _ _ _ expr ->+ [ toHie expr+ ]+ HsTickPragma _ _ _ _ expr ->+ [ toHie expr+ ]+ HsWrap _ _ a ->+ [ toHie $ L mspan a+ ]+ HsBracket _ b ->+ [ toHie b+ ]+ HsRnBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsTcBracketOut _ b p ->+ [ toHie b+ , toHie p+ ]+ HsSpliceE _ x ->+ [ toHie $ L mspan x+ ]+ EWildPat _ -> []+ EAsPat _ a b ->+ [ toHie $ C Use a+ , toHie b+ ]+ EViewPat _ a b ->+ [ toHie a+ , toHie b+ ]+ ELazyPat _ a ->+ [ toHie a+ ]+ XExpr _ -> []++instance ( a ~ GhcPass p+ , ToHie (LHsExpr a)+ , Data (HsTupArg a)+ ) => ToHie (LHsTupArg (GhcPass p)) where+ toHie (L span arg) = concatM $ makeNode arg span : case arg of+ Present _ expr ->+ [ toHie expr+ ]+ Missing _ -> []+ XTupArg _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (LHsLocalBinds a))+ , ToHie (RScoped (ApplicativeArg a))+ , ToHie (Located body)+ , Data (StmtLR a a (Located body))+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : 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+ ]+ XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsLocalBinds a)+ ) => ToHie (RScoped (LHsLocalBinds a)) where+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+ EmptyLocalBinds _ -> []+ HsIPBinds _ _ -> []+ HsValBinds _ valBinds ->+ [ toHie $ RS (combineScopes scope $ mkScope sp)+ valBinds+ ]+ XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (XXValBindsLR a a))+ ) => ToHie (RScoped (HsValBindsLR a a)) 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 ToHie (RScoped (NHsValBindsLR GhcTc)) 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 (RScoped (NHsValBindsLR GhcRn)) 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 (RContext (LHsRecField a arg))+ ) => ToHie (RContext (HsRecFields a arg)) where+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+ , ToHie arg+ , HasLoc arg+ , Data label+ , Data arg+ ) => 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)+ ]+ XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of+ FieldOcc var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XFieldOcc _ -> []++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 _ ->+ [ ]+ XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+ Unambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ Ambiguous var _ ->+ let var' = setVarName var (varName var)+ in [ toHie $ C (RecField c rhs) (L nspan var')+ ]+ XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (StmtLR a a (Located (HsExpr a)))+ , Data (HsLocalBinds a)+ ) => 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+ ]+ toHie (RS _ (XApplicativeArg _)) = pure []++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 ( ToHie (LHsCmd a)+ , Data (HsCmdTop a)+ ) => ToHie (LHsCmdTop a) where+ toHie (L span top) = concatM $ makeNode top span : case top of+ HsCmdTop _ cmd ->+ [ toHie cmd+ ]+ XCmdTop _ -> []++instance ( a ~ GhcPass p+ , ToHie (PScoped (LPat a))+ , ToHie (BindContext (LHsBind a))+ , ToHie (LHsExpr a)+ , ToHie (MatchGroup a (LHsCmd a))+ , ToHie (SigContext (LSig a))+ , ToHie (RScoped (HsValBindsLR a a))+ , Data (HsCmd a)+ , Data (HsCmdTop a)+ , Data (StmtLR a a (Located (HsCmd a)))+ , Data (HsLocalBinds a)+ , Data (StmtLR a a (Located (HsExpr a)))+ ) => 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+ ]+ HsCmdIf _ _ a b c ->+ [ toHie a+ , toHie b+ , toHie c+ ]+ HsCmdLet _ binds cmd' ->+ [ toHie $ RS (mkLScope cmd') binds+ , toHie cmd'+ ]+ HsCmdDo _ (L ispan stmts) ->+ [ pure $ locOnly ispan+ , toHie $ listScopes NoScope stmts+ ]+ HsCmdWrap _ _ _ -> []+ XCmd _ -> []++instance ToHie (TyClGroup GhcRn) where+ toHie (TyClGroup _ classes roles instances) = concatM+ [ toHie classes+ , toHie roles+ , toHie instances+ ]+ toHie (XTyClGroup _) = pure []++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 (pure . locOnly . getLoc) deftyps+ , toHie $ map (go . unLoc) deftyps+ ]+ where+ context_scope = mkLScope context+ rhs_scope = foldl1' combineScopes $ map mkScope+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]++ go :: TyFamDefltEqn GhcRn+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)+ go (FamEqn a var bndrs pat b rhs) =+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs+ go (XFamEqn NoExt) = XFamEqn NoExt+ XTyClDecl _ -> []++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+ XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+ toHie (ClosedTypeFamily (Just eqns)) = concatM $+ [ concatMapM (pure . 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+ ]+ XFamilyResultSig _ -> []++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 pats, ToHie rhs, HasLoc pats, HasLoc rhs)+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where+ toHie (TS _ f) = toHie f++instance ( ToHie pats+ , ToHie rhs+ , HasLoc pats+ , HasLoc rhs+ ) => ToHie (FamEqn GhcRn pats 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)+ toHie (XFamEqn _) = pure []++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+ ]+ toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+ toHie (L span clauses) = concatM+ [ pure $ 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+ , pure $ locOnly ispan+ , toHie $ map (TS (ResolvedScopes [])) tys+ ]+ XHsDerivingClause _ -> []++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 _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ ConDeclGADT { con_names = names, con_qvars = qvars+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+ , toHie ctx+ , toHie args+ , toHie typ+ ]+ where+ rhsScope = combineScopes argsScope tyScope+ ctxScope = maybe NoScope mkLScope ctx+ argsScope = condecl_scope args+ tyScope = mkLScope typ+ 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+ XConDecl _ -> []+ where condecl_scope args = case args of+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+ RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+ toHie (L span decls) = concatM $+ [ pure $ locOnly span+ , toHie decls+ ]++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+ toHie (TS sc (HsIB ibrn a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+ , ToHie (TScoped thing)+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+ toHie (TS sc (HsWC names a)) = concatM $+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+ , toHie $ TS sc a+ ]+ where span = loc a+ toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (SigContext (LSig GhcRn)) where+ toHie (SC (SI styp msp) (L sp sig)) = 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+ , pure $ maybe [] (locOnly . getLoc) mtxt+ ]+ CompleteMatchSig _ _ (L ispan names) typ ->+ [ pure $ locOnly ispan+ , toHie $ map (C Use) names+ , toHie $ fmap (C Use) typ+ ]+ XSig _ -> []++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 _ bndrs body ->+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) 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 _ a b ->+ [ 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) = pure $ locOnly sp++instance ToHie (TVScoped (LHsTyVarBndr 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+ ]+ XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $+ [ pure $ bindingsOnly bindings+ , toHie $ tvScopes sc NoScope vars+ ]+ where+ varLoc = loc vars+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+ toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+ toHie (L span tys) = concatM $+ [ pure $ 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+ ]+ XConDeclField _ -> []++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+ ]+ XSpliceDecl _ -> []++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 ( ToHie (LHsExpr a)+ , Data (HsSplice a)+ ) => ToHie (Located (HsSplice a)) where+ toHie (L span sp) = concatM $ makeNode sp span : case sp of+ HsTypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsUntypedSplice _ _ _ expr ->+ [ toHie expr+ ]+ HsQuasiQuote _ _ _ ispan _ ->+ [ pure $ locOnly ispan+ ]+ HsSpliced _ _ _ ->+ []+ HsSplicedT _ ->+ []+ XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+ toHie (L span annot) = concatM $ makeNode annot span : case annot of+ RoleAnnotDecl _ var roles ->+ [ toHie $ C Use var+ , concatMapM (pure . locOnly . getLoc) roles+ ]+ XRoleAnnotDecl _ -> []++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+ ]+ XInstDecl _ -> []++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+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+ , toHie $ cid_tyfam_insts decl+ , pure $ concatMap (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+ ]+ XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+ toHie (L span sig) = concatM $ makeNode sig span : case sig of+ FixitySig _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ DefaultDecl _ typs ->+ [ toHie typs+ ]+ XDefaultDecl _ -> []++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+ ]+ XForeignDecl _ -> []++instance ToHie ForeignImport where+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ , locOnly c+ ]++instance ToHie ForeignExport where+ toHie (CExport (L a _) (L b _)) = pure $ concat $+ [ locOnly a+ , locOnly b+ ]++instance ToHie (LWarnDecls GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warnings _ _ warnings ->+ [ toHie warnings+ ]+ XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ Warning _ vars _ ->+ [ toHie $ map (C Use) vars+ ]+ XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+ toHie (L span decl) = concatM $ makeNode decl span : case decl of+ HsAnnotation _ _ prov expr ->+ [ toHie prov+ , toHie expr+ ]+ XAnnDecl _ -> []++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+ ]+ XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+ toHie (L _ (XRuleDecl _)) = pure []+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM+ [ makeNode r span+ , pure $ 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+ ]+ XRuleBndr _ -> []++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+ ]+ XImportDecl _ -> []+ where+ goIE (hiding, (L sp liens)) = concatM $+ [ pure $ 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 _ _ -> []+ XIE _ -> []++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+ ]+
+ src-ghc88/Compat/HieBin.hs view
@@ -0,0 +1,389 @@+{-+Binary serialization for .hie files.+-}+{- HLINT ignore -}+{-# LANGUAGE ScopedTypeVariables #-}+module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic,NameCacheUpdater(..)) where++import Config ( cProjectVersion )+import Binary+import BinIface ( getDictFastString )+import FastMutInt+import FastString ( FastString )+import Module ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply ( takeUniqFromSupply )+import Util ( maybeRead )+import Unique+import UniqFM+import IfaceEnv++import qualified Data.Array as A+import Data.IORef+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.List ( mapAccumR )+import Data.Word ( Word8, Word32 )+import Control.Monad ( replicateM, when )+import System.Directory ( createDirectoryIfMissing )+import System.FilePath ( takeDirectory )++import HieTypes++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+ = ExternalName !Module !OccName !SrcSpan+ | LocalName !OccName !SrcSpan+ | KnownKeyName !Unique+ deriving (Eq)++instance Ord HieName where+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+ compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+ -- Not actually non determinstic as it is a KnownKey+ compare ExternalName{} _ = LT+ compare LocalName{} ExternalName{} = GT+ compare LocalName{} _ = LT+ compare KnownKeyName{} _ = GT++instance Outputable HieName where+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u+++data HieSymbolTable = HieSymbolTable+ { hie_symtab_next :: !FastMutInt+ , hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))+ }++data HieDictionary = HieDictionary+ { hie_dict_next :: !FastMutInt -- The next index to use+ , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+ }++initBinMemSize :: Int+initBinMemSize = 1024*1024++-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+ mapM_ (putByte bh) $ BS.unpack xs+ putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO ()+writeHieFile hie_file_path hiefile = do+ bh0 <- openBinMem initBinMemSize++ -- Write the header: hieHeader followed by the+ -- hieVersion and the GHC version used to generate this file+ mapM_ (putByte bh0) hieMagic+ putBinLine bh0 $ BSC.pack $ show hieVersion+ putBinLine bh0 $ ghcVersion++ -- remember where the dictionary pointer will go+ dict_p_p <- tellBin bh0+ put_ bh0 dict_p_p++ -- remember where the symbol table pointer will go+ symtab_p_p <- tellBin bh0+ put_ bh0 symtab_p_p++ -- Make some intial state+ symtab_next <- newFastMutInt+ writeFastMutInt symtab_next 0+ symtab_map <- newIORef emptyUFM+ let hie_symtab = HieSymbolTable {+ hie_symtab_next = symtab_next,+ hie_symtab_map = symtab_map }+ dict_next_ref <- newFastMutInt+ writeFastMutInt dict_next_ref 0+ dict_map_ref <- newIORef emptyUFM+ let hie_dict = HieDictionary {+ hie_dict_next = dict_next_ref,+ hie_dict_map = dict_map_ref }++ -- put the main thing+ let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+ (putName hie_symtab)+ (putFastString hie_dict)+ put_ bh hiefile++ -- write the symtab pointer at the front of the file+ symtab_p <- tellBin bh+ putAt bh symtab_p_p symtab_p+ seekBin bh symtab_p++ -- write the symbol table itself+ symtab_next' <- readFastMutInt symtab_next+ symtab_map' <- readIORef symtab_map+ putSymbolTable bh symtab_next' symtab_map'++ -- write the dictionary pointer at the front of the file+ dict_p <- tellBin bh+ putAt bh dict_p_p dict_p+ seekBin bh dict_p++ -- write the dictionary itself+ dict_next <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+ putDictionary bh dict_next dict_map++ -- and send the result to the file+ createDirectoryIfMissing True (takeDirectory hie_file_path)+ writeBinMem bh hie_file_path+ return ()++data HieFileResult+ = HieFileResult+ { hie_file_result_version :: Integer+ , hie_file_result_ghc_version :: ByteString+ , hie_file_result :: HieFile+ }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult)+readHieFileWithVersion readVersion ncu file = do+ bh0 <- readBinMem file++ (hieVersion, ghcVersion) <- readHieFileHeader file bh0++ if readVersion (hieVersion, ghcVersion)+ then do+ hieFile <- readHieFileContents bh0 ncu+ return $ Right (HieFileResult hieVersion ghcVersion hieFile)+ else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult+readHieFile ncu file = do++ bh0 <- readBinMem file++ (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++ -- Check if the versions match+ when (readHieVersion /= hieVersion) $+ panic $ unwords ["readHieFile: hie file versions don't match for file:"+ , file+ , "Expected"+ , show hieVersion+ , "but got", show readHieVersion+ ]+ hieFile <- readHieFileContents bh0 ncu+ return $ HieFileResult hieVersion ghcVersion hieFile++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+ where+ loop acc = do+ char <- get bh :: IO Word8+ if char == 10 -- ASCII newline '\n'+ then return acc+ else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+ -- Read the header+ magic <- replicateM hieMagicLen (get bh0)+ version <- BSC.unpack <$> readBinLine bh0+ case maybeRead version of+ Nothing ->+ panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+ , show version+ ]+ Just readHieVersion -> do+ ghcVersion <- readBinLine bh0++ -- Check if the header is valid+ when (magic /= hieMagic) $+ panic $ unwords ["readHieFileHeader: headers don't match for file:"+ , file+ , "Expected"+ , show hieMagic+ , "but got", show magic+ ]+ return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile+readHieFileContents bh0 ncu = do++ dict <- get_dictionary bh0++ -- read the symbol table so we are capable of reading the actual data+ bh1 <- do+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+ (getDictFastString dict)+ symtab <- get_symbol_table bh1+ let bh1' = setUserData bh1+ $ newReadState (getSymTabName symtab)+ (getDictFastString dict)+ return bh1'++ -- load the actual data+ hiefile <- get bh1+ return hiefile+ where+ get_dictionary bin_handle = do+ dict_p <- get bin_handle+ data_p <- tellBin bin_handle+ seekBin bin_handle dict_p+ dict <- getDictionary bin_handle+ seekBin bin_handle data_p+ return dict++ get_symbol_table bh1 = do+ symtab_p <- get bh1+ data_p' <- tellBin bh1+ seekBin bh1 symtab_p+ symtab <- getSymbolTable bh1 ncu+ seekBin bh1 data_p'+ return symtab++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+ hie_dict_map = out_r} bh f+ = do+ out <- readIORef out_r+ let unique = getUnique f+ case lookupUFM out unique of+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)+ Nothing -> do+ j <- readFastMutInt j_r+ put_ bh (fromIntegral j :: Word32)+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+ put_ bh next_off+ let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+ mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+ sz <- get bh+ od_names <- replicateM sz (getHieName bh)+ updateNameCache ncu $ \nc ->+ let arr = A.listArray (0,sz-1) names+ (nc', names) = mapAccumR fromHieName nc od_names+ in (nc',arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+ i :: Word32 <- get bh+ return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+ symmap <- readIORef ref+ case lookupUFM symmap name of+ Just (off, ExternalName mod occ (UnhelpfulSpan _))+ | isGoodSrcSpan (nameSrcSpan name) -> do+ let hieName = ExternalName mod occ (nameSrcSpan name)+ writeIORef ref $! addToUFM symmap name (off, hieName)+ put_ bh (fromIntegral off :: Word32)+ Just (off, LocalName _occ span)+ | notLocal (toHieName name) || nameSrcSpan name /= span -> do+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)+ Just (off, _) -> put_ bh (fromIntegral off :: Word32)+ Nothing -> do+ off <- readFastMutInt next+ writeFastMutInt next (off+1)+ writeIORef ref $! addToUFM symmap name (off, toHieName name)+ put_ bh (fromIntegral off :: Word32)++ where+ notLocal :: HieName -> Bool+ notLocal LocalName{} = False+ notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+ | isKnownKeyName name = KnownKeyName (nameUnique name)+ | isExternalName name = ExternalName (nameModule name)+ (nameOccName name)+ (nameSrcSpan name)+ | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+ let cache = nsNames nc+ in case lookupOrigNameCache cache mod occ of+ Just name+ | nameSrcSpan name == span -> (nc, name)+ | otherwise ->+ let name' = setNameLoc name span+ new_cache = extendNameCache cache mod occ name'+ in ( nc{ nsNames = new_cache }, name' )+ Nothing ->+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkExternalName uniq mod occ span+ new_cache = extendNameCache cache mod occ name+ in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+ let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+ name = mkInternalName uniq occ span+ in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+ Nothing -> pprPanic "fromHieName:unknown known-key unique"+ (ppr (unpkUnique u))+ Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+ putByte bh 0+ put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+ putByte bh 1+ put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+ putByte bh 2+ put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+ t <- getByte bh+ case t of+ 0 -> do+ (modu, occ, span) <- get bh+ return $ ExternalName modu occ span+ 1 -> do+ (occ, span) <- get bh+ return $ LocalName occ span+ 2 -> do+ (c,i) <- get bh+ return $ KnownKeyName $ mkUnique c i+ _ -> panic "HieBin.getHieName: invalid tag"
+ src-reexport/Compat/HieDebug.hs view
@@ -0,0 +1,3 @@+module Compat.HieDebug+ ( module HieDebug ) where+import HieDebug
+ src-reexport/Compat/HieTypes.hs view
@@ -0,0 +1,3 @@+module Compat.HieTypes+ ( module HieTypes ) where+import HieTypes
+ src-reexport/Compat/HieUtils.hs view
@@ -0,0 +1,3 @@+module Compat.HieUtils+ ( module HieUtils ) where+import HieUtils