diff options
| -rw-r--r-- | compiler/basicTypes/RdrName.lhs | 11 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 17 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 57 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 3 |
4 files changed, 58 insertions, 30 deletions
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index d4afaf10fc..b9e3fcbd6a 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -157,9 +157,14 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) - Orig (nameModule n) - (setOccNameSpace ns (nameOccName n)) +setRdrNameSpace (Exact n) ns + | isExternalName n + = Orig (nameModule n) occ + | otherwise -- This can happen when quoting and then splicing a fixity + -- declaration for a type + = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n) + where + occ = setOccNameSpace ns (nameOccName n) -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 43d9bfb4e9..6cff928b3c 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -172,7 +172,11 @@ cvtDec (TH.SigD nm typ) ; returnJustL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (TH.InfixD fx nm) - = do { nm' <- vNameL nm + -- fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameL nm ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -521,7 +525,7 @@ cvtPragmaD (AnnP target exp) n' <- tconName n return (TypeAnnProvenance n') ValueAnnotation n -> do - n' <- if isVarName n then vName n else cName n + n' <- vcName n return (ValueAnnProvenance n') ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp' } @@ -1071,9 +1075,10 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = -------------------------------------------------------------------- -- variable names -vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) -vName, cName, tName, tconName :: TH.Name -> CvtM RdrName +vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName +-- Variable names vNameL n = wrapL (vName n) vName n = cvtName OccName.varName n @@ -1081,6 +1086,10 @@ vName n = cvtName OccName.varName n cNameL n = wrapL (cName n) cName n = cvtName OccName.dataName n +-- Variable *or* constructor names; check by looking at the first char +vcNameL n = wrapL (vcName n) +vcName n = if isVarName n then vName n else cName n + -- Type variable names tName n = cvtName OccName.tvName n diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index e33ed15808..0a73585976 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -309,9 +309,21 @@ lookupTopBndrRn_maybe rdr_name ----------------------------------------------- +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This adds an error if the name cannot be found. lookupExactOcc :: Name -> RnM Name --- See Note [Looking up Exact RdrNames] lookupExactOcc name + = do { result <- lookupExactOcc_either name + ; case result of + Left err -> do { addErr err + ; return name } + Right name' -> return name' } + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one. +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +-- See Note [Looking up Exact RdrNames] +lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of ATyCon tc -> Just tc @@ -319,10 +331,10 @@ lookupExactOcc name _ -> Nothing , isTupleTyCon tycon = do { checkTupSize (tyConArity tycon) - ; return name } + ; return (Right name) } | isExternalName name - = return name + = return (Right name) | otherwise = do { env <- getGlobalRdrEnv @@ -337,23 +349,23 @@ lookupExactOcc name ; case gres of [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv - ; unless (name `inLocalRdrEnvScope` lcl_env) $ + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else #ifdef GHCI do { th_topnames_var <- fmap tcg_th_topnames getGblEnv ; th_topnames <- readTcRef th_topnames_var - ; unless (name `elemNameSet` th_topnames) - (addErr exact_nm_err) + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left exact_nm_err) } #else /* !GHCI */ - addErr exact_nm_err + return (Left exact_nm_err) #endif /* !GHCI */ - ; return name } - [gre] -> return (gre_name gre) - (gre:_) -> do {addErr dup_nm_err - ; return (gre_name gre) - } + [gre] -> return (Right (gre_name gre)) + _ -> return (Left dup_nm_err) -- We can get more than one GRE here, if there are multiple -- bindings for the same name. Sometimes they are caught later -- by findLocalDupsRdrEnv, like in this example (Trac #8932): @@ -1034,10 +1046,11 @@ lookupBindGroupOcc :: HsSigCtxt -- See Note [Looking up signature names] lookupBindGroupOcc ctxt what rdr_name | Just n <- isExact_maybe rdr_name - = do { n' <- lookupExactOcc n - ; return (Right n') } -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { n' <- lookupOrig rdr_mod rdr_occ @@ -1114,10 +1127,8 @@ lookupLocalTcNames ctxt what rdr_name dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName -- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] dataTcOccs rdr_name - | Just n <- isExact_maybe rdr_name - , not (isBuiltInSyntax n) -- See Note [dataTcOccs and Exact Names] - = [rdr_name] | isDataOcc occ || isVarOcc occ = [rdr_name, rdr_name_tc] | otherwise @@ -1130,8 +1141,12 @@ dataTcOccs rdr_name Note [dataTcOccs and Exact Names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact, so it's wrong to return the TyClsName too. -But there is an awkward exception for built-in syntax. Example in GHCi +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi :info [] This parses as the Exact RdrName for nilDataCon, but we also want the list type constructor. diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 3d64060f01..342f5e3ed4 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -336,5 +336,4 @@ test('T8953', normal, compile, ['-v0']) test('T9084', normal, compile_fail, ['-v0']) test('T9738', normal, compile, ['-v0']) test('T9081', normal, compile, ['-v0']) -test('T9066', expect_broken(9066), compile, ['-v0']) - +test('T9066', normal, compile, ['-v0']) |