\begin{code}
-module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
+module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
#include "HsVersions.h"
import HsSyn as Hs
import qualified Class (FunDep)
-import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
-import Module ( ModuleName, mkModuleName )
-import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
import Name ( mkInternalName )
+import Module ( Module, mkModule )
+import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName
-import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..),
- noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc )
+import SrcLoc ( generatedSrcLoc, noLoc, unLoc, Located(..),
+ SrcSpan, srcLocSpan )
import Type ( Type )
-import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
+import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
import BasicTypes( Boxity(..), RecFlag(Recursive) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..))
-import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
- ForeignDecl(..) )
-import FastString( FastString, mkFastString, nilFS )
-import Char ( ord, isAscii, isAlphaNum, isAlpha )
+import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition )
import Unique ( Unique, mkUniqueGrimily )
import ErrUtils (Message)
-import GLAEXTS ( Int#, Int(..) )
+import GLAEXTS ( Int(..), Int# )
+import SrcLoc ( noSrcLoc )
import Bag ( emptyBag, consBag )
+import FastString
import Outputable
-- some useful things
truePat = nlConPat (getRdrName trueDataCon) []
-falsePat = nlConPat (getRdrName falseDataCon) []
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
-- This turns a Name into a RdrName
--- The last case is slightly interesting. It constructs a
--- unique name from the unique in the TH thingy, so that the renamer
--- won't mess about. I hope. (Another possiblity would be to generate
--- "x_77" etc, but that could conceivably clash.)
-
-thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
-thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ
-thRdrName ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
-
-mk_uniq :: Int# -> Unique
-mk_uniq u = mkUniqueGrimily (I# u)
+-- The passed-in name space tells what the context is expecting;
+-- use it unless the TH name knows what name-space it comes
+-- from, in which case use the latter
+thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
+thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
+thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ctxt_ns occ)
+thRdrName ctxt_ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ctxt_ns occ)
+thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq)) = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
+
+mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
+mk_uniq_occ ns occ uniq
+ = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
+ -- The idea here is to make a name that
+ -- a) the user could not possibly write, and
+ -- b) cannot clash with another NameU
+ -- Previously I generated an Exact RdrName with mkInternalName.
+ -- This works fine for local binders, but does not work at all for
+ -- top-level binders, which must have External Names, since they are
+ -- rapidly baked into data constructors and the like. Baling out
+ -- and generating an unqualified RdrName here is the simple solution
+
+mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
+mk_ghc_ns DataName = OccName.dataName
+mk_ghc_ns TH.TcClsName = OccName.tcClsName
+mk_ghc_ns TH.VarName = OccName.varName
-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
-mk_mod :: TH.ModName -> ModuleName
-mk_mod mod = mkModuleName (TH.modString mod)
-
-mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName
--- Parse the string to see if it has a "." in it
--- so we know whether to generate a qualified or unqualified name
--- It's a bit tricky because we need to parse
--- Foo.Baz.x as Qual Foo.Baz x
--- So we parse it from back to front
+mk_mod :: TH.ModName -> Module
+mk_mod mod = mkModule (TH.modString mod)
-mkDynName ns th_occ
- = split [] (reverse (TH.occString th_occ))
- where
- split occ [] = mkRdrUnqual (mk_occ occ)
- split occ ('.':rev) = mkRdrQual (mk_mod (reverse rev)) (mk_occ occ)
- split occ (c:rev) = split (c:occ) rev
-
- mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
- mk_mod mod = mkModuleName mod
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
\end{code}