Alan
Interesting. The GlobalRdrEnv is such a mapping.
I'm not sure what the goal is here. Would it be worth a ticket and/or wiki page to explain the problem you are trying to solve?
Simon
| -----Original Message-----
| From: ghc-commits On Behalf Of
| git@git.haskell.org
| Sent: 12 November 2018 18:32
| To: ghc-commits@haskell.org
| Subject: [commit: ghc] wip/az-namemap: Introduce map from RdrName to Name
| for GHC API (2745981)
|
| Repository : ssh://git@git.haskell.org/ghc
|
| On branch : wip/az-namemap
| Link :
| https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fghc.haskel
| l.org%2Ftrac%2Fghc%2Fchangeset%2F2745981fb8a558cd486b674e4b15db8528f0cc78%
| 2Fghc&data=02%7C01%7Csimonpj%40microsoft.com%7C9d848ba78ecd428ff7a508d
| 648cd2a74%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C636776443360189215&
| amp;sdata=o7swv001G%2Bc%2FQAw23xr6GA18iXS8YratFJahszIIRH4%3D&reserved=
| 0
|
| >---------------------------------------------------------------
|
| commit 2745981fb8a558cd486b674e4b15db8528f0cc78
| Author: Alan Zimmerman
| Date: Mon Nov 12 20:26:40 2018 +0200
|
| Introduce map from RdrName to Name for GHC API
|
| Tools need to work with the ParsedSource as a accurate representation
| of the compiled source, but sometimes need access to the actual Names
| used from the renaming phase.
|
| Introduce a function that initialises a NameMap from a TypechedModule,
| for use by GHC API consumers.
|
|
| >---------------------------------------------------------------
|
| 2745981fb8a558cd486b674e4b15db8528f0cc78
| compiler/main/GHC.hs | 133
| +++++++++++++++++++++++++++++++++++++++++++++++++++
| 1 file changed, 133 insertions(+)
|
| diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
| index cf9c74f..9d9cf17 100644
| --- a/compiler/main/GHC.hs
| +++ b/compiler/main/GHC.hs
| @@ -1,5 +1,6 @@
| {-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
| {-# LANGUAGE TupleSections, NamedFieldPuns #-}
| +{-# LANGUAGE RankNTypes #-}
|
| -- ----------------------------------------------------------------------
| -------
| --
| @@ -125,6 +126,7 @@ module GHC (
| -- ** Looking up a Name
| parseName,
| lookupName,
| + initRdrNameMap, NameMap,
|
| -- ** Compiling expressions
| HValue, parseExpr, compileParsedExpr,
| @@ -306,6 +308,7 @@ import TcRnTypes
| import Packages
| import NameSet
| import RdrName
| +import Var
| import HsSyn
| import Type hiding( typeKind )
| import TcType hiding( typeKind )
| @@ -352,7 +355,9 @@ import TcRnDriver
| import Inst
| import FamInst
| import FileCleanup
| +import Unique ( mkUnique )
|
| +import Data.Data ( Data, gmapQ, cast )
| import Data.Foldable
| import qualified Data.Map.Strict as Map
| import Data.Set (Set)
| @@ -1531,6 +1536,134 @@ lookupName :: GhcMonad m => Name -> m (Maybe
| TyThing)
| lookupName name =
| withSession $ \hsc_env ->
| liftIO $ hscTcRcLookupName hsc_env name
| +-- ----------------------------------------------------------------------
| -------
| +
| +-- | Map of 'SrcSpan's from 'Located' 'RdrName's in the 'ParsedSource'
| +-- to the corresponding 'Name' from renaming.
| +type NameMap = Map.Map SrcSpan Name
| +
| +-- | Tools prefer to work with the 'ParsedSource' because it more
| +-- closely reflects the actual source code, but must be able to work
| +-- with the renamed representation of the names involved. This
| +-- function constructs a map from every 'Located' 'RdrName' in the
| +-- 'ParsedSource' to its corresponding name in the 'RenamedSource' and
| +-- 'TypecheckedSource'.
| +initRdrNameMap :: TypecheckedModule -> NameMap
| +initRdrNameMap tm = r
| + where
| + parsed = pm_parsed_source $ tm_parsed_module tm
| + renamed = tm_renamed_source tm
| + typechecked = tm_typechecked_source tm
| +
| + checkRdr :: Located RdrName -> Maybe [(SrcSpan,RdrName)]
| + checkRdr (L l n@(Unqual _)) = Just [(l,n)]
| + checkRdr (L l n@(Qual _ _)) = Just [(l,n)]
| + checkRdr (L _ _)= Nothing
| +
| + checkName :: Located Name -> Maybe [Located Name]
| + checkName ln = Just [ln]
| +
| + rdrNames = fromMaybe (panic "initRdrNameMap")
| + $ everything mappend (nameSybQuery checkRdr ) parsed
| + names1 = fromMaybe (panic "initRdrNameMap")
| + $ everything mappend (nameSybQuery checkName) renamed
| + names2 = names1 ++ everything (++) ([] `mkQ` fieldOcc
| + `extQ` hsRecFieldN) renamed
| + names = names2 ++ everything (++) ([] `mkQ` hsRecFieldT)
| typechecked
| +
| + fieldOcc :: FieldOcc GhcRn -> [Located Name]
| + fieldOcc (FieldOcc n (L l _)) = [(L l n)]
| + fieldOcc XFieldOcc {} = []
| +
| + hsRecFieldN :: LHsExpr GhcRn -> [Located Name]
| + hsRecFieldN (L _ (HsRecFld _ (Unambiguous n (L l _) ))) = [L l n]
| + hsRecFieldN _ = []
| +
| + hsRecFieldT :: LHsExpr GhcTc -> [Located Name]
| + hsRecFieldT (L _ (HsRecFld _ (Ambiguous n (L l _)) ))
| + = [L l (Var.varName n)]
| + hsRecFieldT _ = []
| +
| + nameMap = Map.fromList $ map (\(L l n) -> (l,n)) names
| +
| + -- If the name does not exist (e.g. a TH Splice that has been
| + -- expanded, make a new one)
| + -- No attempt is made to make sure that equivalent ones have
| + -- equivalent names.
| + lookupName l n i = case Map.lookup l nameMap of
| + Just v -> v
| + Nothing ->
| + case n of
| + Unqual u -> mkNewGhcNamePure 'h' i Nothing (occNameString u)
| + Qual q u -> mkNewGhcNamePure 'h' i
| + (Just (Module (stringToUnitId "") q))
| (occNameString u)
| + _ -> panic "initRdrNameMap"
| +
| + r = Map.fromList $ map (\((l,n),i) -> (l,lookupName l n i))
| + $ zip rdrNames [1..]
| +
| + nameSybQuery :: (Typeable a, Typeable t)
| + => (Located a -> Maybe r) -> t -> Maybe r
| + nameSybQuery checker = q
| + where
| + q = Nothing `mkQ` worker
| +
| + worker (pnt :: (Located a))
| + = checker pnt
| +
| + mkNewGhcNamePure :: Char -> Int -> Maybe Module -> String -> Name
| + mkNewGhcNamePure c i maybeMod name =
| + let un = mkUnique c i -- H for HaRe :)
| + n = case maybeMod of
| + Nothing -> mkInternalName un (mkVarOcc name)
| noSrcSpan
| + Just modu -> mkExternalName un modu (mkVarOcc name)
| noSrcSpan
| + in n
| +
| +
| +-- Copied from SYB
| +
| +
| +-- | Generic queries of type \"r\",
| +-- i.e., take any \"a\" and return an \"r\"
| +--
| +type GenericQ r = forall a. Data a => a -> r
| +
| +
| +-- | Make a generic query;
| +-- start from a type-specific case;
| +-- return a constant otherwise
| +--
| +mkQ :: ( Typeable a
| + , Typeable b
| + )
| + => r
| + -> (b -> r)
| + -> a
| + -> r
| +(r `mkQ` br) a = case cast a of
| + Just b -> br b
| + Nothing -> r
| +
| +-- | Extend a generic query by a type-specific case
| +extQ :: ( Typeable a
| + , Typeable b
| + )
| + => (a -> q)
| + -> (b -> q)
| + -> a
| + -> q
| +extQ f g a = maybe (f a) g (cast a)
| +
| +
| +
| +-- | Summarise all nodes in top-down, left-to-right order
| +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r
| +
| +-- Apply f to x to summarise top-level node;
| +-- use gmapQ to recurse into immediate subterms;
| +-- use ordinary foldl to reduce list of intermediate results
| +
| +everything k f x = foldl k (f x) (gmapQ (everything k f) x)
|
| -- ----------------------------------------------------------------------
| -------
| -- Pure API
|
| _______________________________________________
| ghc-commits mailing list
| ghc-commits@haskell.org
| https://na01.safelinks.protection.outlook.com/?url=http%3A%2F%2Fmail.haske
| ll.org%2Fcgi-bin%2Fmailman%2Flistinfo%2Fghc-
| commits&data=02%7C01%7Csimonpj%40microsoft.com%7C9d848ba78ecd428ff7a50
| 8d648cd2a74%7C72f988bf86f141af91ab2d7cd011db47%7C1%7C0%7C63677644336018921
| 5&sdata=fLoupgPItcbuELQ%2B7bnPKHXZ595utTpqL%2FzwLELpSuk%3D&reserve
| d=0
