ghc/compiler/hsSyn/Convert.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4
   5 This module converts Template Haskell syntax into HsSyn
   6
   7
   8 \begin{code}
   9 module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
  10
  11 #include "HsVersions.h"
  12
  13 import Language.Haskell.TH as TH hiding (sigP)
  14 import Language.Haskell.TH.Syntax as TH
  15
  16 import HsSyn as Hs
  17 import qualified Class (FunDep)
  18 import RdrName  ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
  19 import Name     ( mkInternalName )
  20 import Module   ( Module, mkModule )
  21 import RdrHsSyn ( mkClassDecl, mkTyData )
  22 import qualified OccName
  23 import SrcLoc   ( unLoc, Located(..), SrcSpan )
  24 import Type     ( Type )
  25 import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
  26 import BasicTypes( Boxity(..) )
  27 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
  28                      CExportSpec(..))
  29 import Char     ( isAscii, isAlphaNum, isAlpha )
  30 import List     ( partition )
  31 import Unique   ( Unique, mkUniqueGrimily )
  32 import ErrUtils (Message)
  33 import GLAEXTS  ( Int(..), Int# )
  34 import SrcLoc   ( noSrcLoc )
  35 import Bag      ( emptyBag, consBag )
  36 import FastString
  37 import Outputable
  38
  39
  40 -------------------------------------------------------------------
  41 convertToHsDecls :: SrcSpan -> [TH.Dec] -> [Either (LHsDecl RdrName) Message]
  42 -- Use the loc everywhere, for lack of anything better
  43 -- In particular, we want it on binding locations, so that variables bound in
  44 -- the spliced-in declarations get a location that at least relates to the splice point
  45 convertToHsDecls loc ds = map (cvt_top loc) ds
  46
  47 cvt_top :: SrcSpan -> TH.Dec -> Either (LHsDecl RdrName) Message
  48 cvt_top loc d@(TH.ValD _ _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
  49 cvt_top loc d@(TH.FunD _ _)   = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
  50 cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (Sig (L loc (vName nm)) (cvtType loc typ))
  51
  52 cvt_top loc (TySynD tc tvs rhs)
  53   = Left $ L loc $ TyClD (TySynonym (L loc (tconName tc)) (cvt_tvs loc tvs) (cvtType loc rhs))
  54
  55 cvt_top loc (DataD ctxt tc tvs constrs derivs)
  56   = Left $ L loc $ TyClD (mkTyData DataType
  57                            (L loc (cvt_context loc ctxt, L loc (tconName tc), cvt_tvs loc tvs))
  58                            Nothing (map (mk_con loc) constrs)
  59                            (mk_derivs loc derivs))
  60
  61 cvt_top loc (NewtypeD ctxt tc tvs constr derivs)
  62   = Left $ L loc $ TyClD (mkTyData NewType
  63                            (L loc (cvt_context loc ctxt, L loc (tconName tc), cvt_tvs loc tvs))
  64                            Nothing [mk_con loc constr]
  65                            (mk_derivs loc derivs))
  66
  67 cvt_top loc (ClassD ctxt cl tvs fds decs)
  68   = Left $ L loc $ TyClD $ mkClassDecl (cvt_context loc ctxt,
  69                                 L loc (tconName cl),
  70                                 cvt_tvs loc tvs)
  71                                (map (L loc . cvt_fundep) fds)
  72                                sigs
  73                                binds
  74   where
  75     (binds,sigs) = cvtBindsAndSigs loc decs
  76
  77 cvt_top loc (InstanceD tys ty decs)
  78   = Left $ L loc $ InstD (InstDecl (L loc inst_ty) binds sigs)
  79   where
  80     (binds, sigs) = cvtBindsAndSigs loc decs
  81     inst_ty = mkImplicitHsForAllTy (cvt_context loc tys) (L loc (HsPredTy (cvt_pred loc ty)))
  82
  83 cvt_top loc (ForeignD (ImportF callconv safety from nm typ))
  84  = case parsed of
  85        Just (c_header, cis) ->
  86            let i = CImport callconv' safety' c_header nilFS cis
  87            in Left $ L loc $ ForD (ForeignImport (L loc (vName nm)) (cvtType loc typ) i False)
  88        Nothing -> Right $     text (show from)
  89                           <+> ptext SLIT("is not a valid ccall impent")
  90     where callconv' = case callconv of
  91                           CCall -> CCallConv
  92                           StdCall -> StdCallConv
  93           safety' = case safety of
  94                         Unsafe     -> PlayRisky
  95                         Safe       -> PlaySafe False
  96                         Threadsafe -> PlaySafe True
  97           parsed = parse_ccall_impent (TH.nameBase nm) from
  98
  99 cvt_top loc (ForeignD (ExportF callconv as nm typ))
 100  = let e = CExport (CExportStatic (mkFastString as) callconv')
 101    in Left $ L loc $ ForD (ForeignExport (L loc (vName nm)) (cvtType loc typ) e False)
 102     where callconv' = case callconv of
 103                           CCall -> CCallConv
 104                           StdCall -> StdCallConv
 105
 106 mk_con loc con = L loc $ mk_nlcon con
 107   where
 108     mk_nlcon con = case con of
 109         NormalC c strtys
 110          -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
 111                   (PrefixCon (map mk_arg strtys))
 112         RecC c varstrtys
 113          -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
 114                   (RecCon (map mk_id_arg varstrtys))
 115         InfixC st1 c st2
 116          -> ConDecl (L loc (cName c)) noExistentials (noContext loc)
 117                   (InfixCon (mk_arg st1) (mk_arg st2))
 118         ForallC tvs ctxt (ForallC tvs' ctxt' con')
 119          -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 120         ForallC tvs ctxt con' -> case mk_nlcon con' of
 121                                 ConDecl l [] (L _ []) x ->
 122                                     ConDecl l (cvt_tvs loc tvs) (cvt_context loc ctxt) x
 123                                 c -> panic "ForallC: Can't happen"
 124     mk_arg (IsStrict, ty)  = L loc $ HsBangTy HsStrict (cvtType loc ty)
 125     mk_arg (NotStrict, ty) = cvtType loc ty
 126
 127     mk_id_arg (i, IsStrict, ty)
 128         = (L loc (vName i), L loc $ HsBangTy HsStrict (cvtType loc ty))
 129     mk_id_arg (i, NotStrict, ty)
 130         = (L loc (vName i), cvtType loc ty)
 131
 132 mk_derivs loc [] = Nothing
 133 mk_derivs loc cs = Just [L loc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
 134
 135 cvt_fundep :: FunDep -> Class.FunDep RdrName
 136 cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
 137
 138 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 139 parse_ccall_impent nm s
 140  = case lex_ccall_impent s of
 141        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 142        Just ["wrapper"] -> Just (nilFS, CWrapper)
 143        Just ("static":ts) -> parse_ccall_impent_static nm ts
 144        Just ts -> parse_ccall_impent_static nm ts
 145        Nothing -> Nothing
 146
 147 parse_ccall_impent_static :: String
 148                           -> [String]
 149                           -> Maybe (FastString, CImportSpec)
 150 parse_ccall_impent_static nm ts
 151  = let ts' = case ts of
 152                  [       "&", cid] -> [       cid]
 153                  [fname, "&"     ] -> [fname     ]
 154                  [fname, "&", cid] -> [fname, cid]
 155                  _                 -> ts
 156    in case ts' of
 157           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
 158           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
 159           [          ]              -> Just (nilFS,              mk_cid nm)
 160           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
 161           _                         -> Nothing
 162     where is_cid :: String -> Bool
 163           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 164           mk_cid :: String -> CImportSpec
 165           mk_cid  = CFunction . StaticTarget . mkFastString
 166
 167 lex_ccall_impent :: String -> Maybe [String]
 168 lex_ccall_impent "" = Just []
 169 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 170 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 171 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 172 lex_ccall_impent xs = case span is_valid xs of
 173                           ("", _) -> Nothing
 174                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 175     where is_valid :: Char -> Bool
 176           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 177
 178 noContext loc  = L loc []
 179 noExistentials = []
 180
 181 -------------------------------------------------------------------
 182 convertToHsExpr :: SrcSpan -> TH.Exp -> LHsExpr RdrName
 183 convertToHsExpr loc e = cvtl loc e
 184
 185 cvtl loc e = cvt_l e
 186   where
 187     cvt_l e = L loc (cvt e)
 188
 189     cvt (VarE s)        = HsVar (vName s)
 190     cvt (ConE s)        = HsVar (cName s)
 191     cvt (LitE l)
 192       | overloadedLit l = HsOverLit (cvtOverLit l)
 193       | otherwise       = HsLit (cvtLit l)
 194
 195     cvt (AppE x y)     = HsApp (cvt_l x) (cvt_l y)
 196     cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map (cvtlp loc) ps) (cvtl loc e)])
 197     cvt (TupE [e])     = cvt e
 198     cvt (TupE es)      = ExplicitTuple(map cvt_l es) Boxed
 199     cvt (CondE x y z)  = HsIf (cvt_l x) (cvt_l y) (cvt_l z)
 200     cvt (LetE ds e)        = HsLet (cvtdecs loc ds) (cvt_l e)
 201     cvt (CaseE e ms)   = HsCase (cvt_l e) (mkMatchGroup (map (cvtm loc) ms))
 202     cvt (DoE ss)       = cvtHsDo loc DoExpr ss
 203     cvt (CompE ss)     = cvtHsDo loc ListComp ss
 204     cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd loc dd)
 205     cvt (ListE xs)     = ExplicitList void (map cvt_l xs)
 206     cvt (InfixE (Just x) s (Just y))
 207         = HsPar (L loc $ OpApp (cvt_l x) (cvt_l s) undefined (cvt_l y))
 208     cvt (InfixE Nothing  s (Just y)) = SectionR (cvt_l s) (cvt_l y)
 209     cvt (InfixE (Just x) s Nothing ) = SectionL (cvt_l x) (cvt_l s)
 210     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 211     cvt (SigE e t)              = ExprWithTySig (cvt_l e) (cvtType loc t)
 212     cvt (RecConE c flds) = RecordCon (L loc (cName c)) noPostTcExpr
 213                                  (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
 214     cvt (RecUpdE e flds) = RecordUpd (cvt_l e) (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
 215                                  placeHolderType placeHolderType
 216
 217 cvtHsDo loc do_or_lc stmts
 218   = HsDo do_or_lc (init stmts') body void
 219   where
 220     stmts' = cvtstmts loc stmts
 221     body = case last stmts' of
 222                 L _ (ExprStmt body _ _) -> body
 223
 224 cvtdecs :: SrcSpan -> [TH.Dec] -> HsLocalBinds RdrName
 225 cvtdecs loc [] = EmptyLocalBinds
 226 cvtdecs loc ds = HsValBinds (ValBindsIn binds sigs)
 227            where
 228              (binds, sigs) = cvtBindsAndSigs loc ds
 229
 230 cvtBindsAndSigs loc ds
 231   = (cvtds loc non_sigs, map (cvtSig loc) sigs)
 232   where
 233     (sigs, non_sigs) = partition sigP ds
 234
 235 cvtSig loc (TH.SigD nm typ) = L loc (Hs.Sig (L loc (vName nm)) (cvtType loc typ))
 236
 237 cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
 238 cvtds loc []     = emptyBag
 239 cvtds loc (d:ds) = cvtd loc d `consBag` cvtds loc ds
 240
 241 cvtd :: SrcSpan -> TH.Dec -> LHsBind RdrName
 242 -- Used only for declarations in a 'let/where' clause,
 243 -- not for top level decls
 244 cvtd loc (TH.ValD (TH.VarP s) body ds)
 245   = L loc $ FunBind (L loc (vName s)) False
 246                     (mkMatchGroup [cvtclause loc (Clause [] body ds)])
 247                     placeHolderNames
 248 cvtd loc (FunD nm cls)
 249   = L loc $ FunBind (L loc (vName nm)) False
 250                     (mkMatchGroup (map (cvtclause loc) cls))
 251                     placeHolderNames
 252 cvtd loc (TH.ValD p body ds)
 253   = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds))
 254                     void placeHolderNames
 255
 256 cvtd loc d = cvtPanic "Illegal kind of declaration in where clause"
 257                   (text (TH.pprint d))
 258
 259
 260 cvtclause :: SrcSpan -> TH.Clause -> Hs.LMatch RdrName
 261 cvtclause loc (Clause ps body wheres)
 262     = L loc $ Hs.Match (map (cvtlp loc) ps) Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres))
 263
 264
 265
 266 cvtdd :: SrcSpan -> Range -> ArithSeqInfo RdrName
 267 cvtdd loc (FromR x)           = (From (cvtl loc x))
 268 cvtdd loc (FromThenR x y)     = (FromThen (cvtl loc x) (cvtl loc y))
 269 cvtdd loc (FromToR x y)       = (FromTo (cvtl loc x) (cvtl loc y))
 270 cvtdd loc (FromThenToR x y z) = (FromThenTo (cvtl loc x) (cvtl loc y) (cvtl loc z))
 271
 272
 273 cvtstmts :: SrcSpan -> [TH.Stmt] -> [Hs.LStmt RdrName]
 274 cvtstmts loc []              = []
 275 cvtstmts loc (NoBindS e : ss)    = L loc (mkExprStmt (cvtl loc e))           : cvtstmts loc ss
 276 cvtstmts loc (TH.BindS p e : ss) = L loc (mkBindStmt (cvtlp loc p) (cvtl loc e)) : cvtstmts loc ss
 277 cvtstmts loc (TH.LetS ds : ss)   = L loc (LetStmt (cvtdecs loc ds))          : cvtstmts loc ss
 278 cvtstmts loc (TH.ParS dss : ss)  = L loc (ParStmt [(cvtstmts loc ds, undefined) | ds <- dss]) : cvtstmts loc ss
 279
 280 cvtm :: SrcSpan -> TH.Match -> Hs.LMatch RdrName
 281 cvtm loc (TH.Match p body wheres)
 282     = L loc (Hs.Match [cvtlp loc p] Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres)))
 283
 284 cvtguard :: SrcSpan -> TH.Body -> [LGRHS RdrName]
 285 cvtguard loc (GuardedB pairs) = map (cvtpair loc) pairs
 286 cvtguard loc (NormalB e)      = [L loc (GRHS [] (cvtl loc e))]
 287
 288 cvtpair :: SrcSpan -> (TH.Guard,TH.Exp) -> LGRHS RdrName
 289 cvtpair loc (NormalG x,y) = L loc (GRHS [L loc $ mkBindStmt truePat (cvtl loc x)]
 290                                     (cvtl loc y))
 291 cvtpair loc (PatG x,y) = L loc (GRHS (cvtstmts loc x) (cvtl loc y))
 292
 293 cvtOverLit :: Lit -> HsOverLit RdrName
 294 cvtOverLit (IntegerL i)  = mkHsIntegral i
 295 cvtOverLit (RationalL r) = mkHsFractional r
 296 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 297 -- Similarly 3.5 for fractionals
 298
 299 cvtLit :: Lit -> HsLit
 300 cvtLit (IntPrimL i)    = HsIntPrim i
 301 cvtLit (FloatPrimL f)  = HsFloatPrim f
 302 cvtLit (DoublePrimL f) = HsDoublePrim f
 303 cvtLit (CharL c)       = HsChar c
 304 cvtLit (StringL s)     = HsString (mkFastString s)
 305
 306 cvtlp :: SrcSpan -> TH.Pat -> Hs.LPat RdrName
 307 cvtlp loc pat = L loc (cvtp loc pat)
 308
 309 cvtp :: SrcSpan -> TH.Pat -> Hs.Pat RdrName
 310 cvtp loc (TH.LitP l)
 311   | overloadedLit l = mkNPat (cvtOverLit l) Nothing     -- Not right for negative
 312                                                         -- patterns; need to think
 313                                                         -- about that!
 314   | otherwise       = Hs.LitPat (cvtLit l)
 315 cvtp loc (TH.VarP s)  = Hs.VarPat(vName s)
 316 cvtp loc (TupP [p])   = cvtp loc p
 317 cvtp loc (TupP ps)    = TuplePat (map (cvtlp loc) ps) Boxed
 318 cvtp loc (ConP s ps)  = ConPatIn (L loc (cName s)) (PrefixCon (map (cvtlp loc) ps))
 319 cvtp loc (InfixP p1 s p2)
 320                   = ConPatIn (L loc (cName s)) (InfixCon (cvtlp loc p1) (cvtlp loc p2))
 321 cvtp loc (TildeP p)   = LazyPat (cvtlp loc p)
 322 cvtp loc (TH.AsP s p) = AsPat (L loc (vName s)) (cvtlp loc p)
 323 cvtp loc TH.WildP   = WildPat void
 324 cvtp loc (RecP c fs)  = ConPatIn (L loc (cName c)) $ Hs.RecCon (map (\(s,p) -> (L loc (vName s),cvtlp loc p)) fs)
 325 cvtp loc (ListP ps)   = ListPat (map (cvtlp loc) ps) void
 326 cvtp loc (SigP p t)   = SigPatIn (cvtlp loc p) (cvtType loc t)
 327
 328 -----------------------------------------------------------
 329 --      Types and type variables
 330
 331 cvt_tvs :: SrcSpan -> [TH.Name] -> [LHsTyVarBndr RdrName]
 332 cvt_tvs loc tvs = map (L loc . UserTyVar . tName) tvs
 333
 334 cvt_context :: SrcSpan -> Cxt -> LHsContext RdrName
 335 cvt_context loc tys = L loc (map (L loc . cvt_pred loc) tys)
 336
 337 cvt_pred :: SrcSpan -> TH.Type -> HsPred RdrName
 338 cvt_pred loc ty
 339   = case split_ty_app ty of
 340         (ConT tc, tys) -> HsClassP (tconName tc) (map (cvtType loc) tys)
 341         (VarT tv, tys) -> HsClassP (tName tv) (map (cvtType loc) tys)
 342         other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
 343
 344 convertToHsType = cvtType
 345
 346 cvtType :: SrcSpan -> TH.Type -> LHsType RdrName
 347 cvtType loc ty = trans (root ty [])
 348   where root (AppT a b) zs = root a (cvtType loc b : zs)
 349         root t zs          = (t,zs)
 350
 351         trans (TupleT n,args)
 352             | length args == n = L loc (HsTupleTy Boxed args)
 353             | n == 0    = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon))        args
 354             | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
 355         trans (ArrowT,   [x,y]) = nlHsFunTy x y
 356         trans (ListT,    [x])   = L loc (HsListTy x)
 357
 358         trans (VarT nm, args)       = foldl nlHsAppTy (nlHsTyVar (tName nm))    args
 359         trans (ConT tc, args)       = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
 360
 361         trans (ForallT tvs cxt ty, []) = L loc $ mkExplicitHsForAllTy
 362                                                 (cvt_tvs loc tvs) (cvt_context loc cxt) (cvtType loc ty)
 363
 364 split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
 365 split_ty_app ty = go ty []
 366   where
 367     go (AppT f a) as = go f (a:as)
 368     go f as          = (f,as)
 369
 370 -----------------------------------------------------------
 371 sigP :: Dec -> Bool
 372 sigP (TH.SigD _ _) = True
 373 sigP other       = False
 374
 375
 376 -----------------------------------------------------------
 377 cvtPanic :: String -> SDoc -> b
 378 cvtPanic herald thing
 379   = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))
 380
 381 -----------------------------------------------------------
 382 -- some useful things
 383
 384 truePat  = nlConPat (getRdrName trueDataCon)  []
 385
 386 overloadedLit :: Lit -> Bool
 387 -- True for literals that Haskell treats as overloaded
 388 overloadedLit (IntegerL  l) = True
 389 overloadedLit (RationalL l) = True
 390 overloadedLit l             = False
 391
 392 void :: Type.Type
 393 void = placeHolderType
 394
 395 --------------------------------------------------------------------
 396 --      Turning Name back into RdrName
 397 --------------------------------------------------------------------
 398
 399 -- variable names
 400 vName :: TH.Name -> RdrName
 401 vName = thRdrName OccName.varName
 402
 403 -- Constructor function names; this is Haskell source, hence srcDataName
 404 cName :: TH.Name -> RdrName
 405 cName = thRdrName OccName.srcDataName
 406
 407 -- Type variable names
 408 tName :: TH.Name -> RdrName
 409 tName = thRdrName OccName.tvName
 410
 411 -- Type Constructor names
 412 tconName = thRdrName OccName.tcName
 413
 414 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
 415 -- This turns a Name into a RdrName
 416 -- The passed-in name space tells what the context is expecting;
 417 --      use it unless the TH name knows what name-space it comes
 418 --      from, in which case use the latter
 419 thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig      (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
 420 thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq))      = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
 421 thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod))       = mkRdrQual   (mk_mod mod) (mk_occ ctxt_ns occ)
 422 thRdrName ctxt_ns (TH.Name occ TH.NameS)             = mkRdrUnqual (mk_occ ctxt_ns occ)
 423 thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq))      = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
 424
 425 mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
 426 mk_uniq_occ ns occ uniq
 427   = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
 428         -- The idea here is to make a name that
 429         -- a) the user could not possibly write, and
 430         -- b) cannot clash with another NameU
 431         -- Previously I generated an Exact RdrName with mkInternalName.
 432         -- This works fine for local binders, but does not work at all for
 433         -- top-level binders, which must have External Names, since they are
 434         -- rapidly baked into data constructors and the like.  Baling out
 435         -- and generating an unqualified RdrName here is the simple solution
 436
 437 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 438 mk_ghc_ns DataName     = OccName.dataName
 439 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 440 mk_ghc_ns TH.VarName   = OccName.varName
 441
 442 -- The packing and unpacking is rather turgid :-(
 443 mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
 444 mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
 445
 446 mk_mod :: TH.ModName -> Module
 447 mk_mod mod = mkModule (TH.modString mod)
 448
 449 mk_uniq :: Int# -> Unique
 450 mk_uniq u = mkUniqueGrimily (I# u)
 451 \end{code}
 452