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 (TypeSig (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         -- Can't handle GADTs yet
 109     mk_nlcon con = case con of
 110         NormalC c strtys
 111          -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
 112                     (PrefixCon (map mk_arg strtys)) ResTyH98
 113         RecC c varstrtys
 114          -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
 115                   (RecCon (map mk_id_arg varstrtys)) ResTyH98
 116         InfixC st1 c st2
 117          -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
 118                   (InfixCon (mk_arg st1) (mk_arg st2)) ResTyH98
 119         ForallC tvs ctxt (ForallC tvs' ctxt' con')
 120          -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 121         ForallC tvs ctxt con' -> case mk_nlcon con' of
 122                                 ConDecl l _ [] (L _ []) x ResTyH98 ->
 123                                     ConDecl l Explicit (cvt_tvs loc tvs) (cvt_context loc ctxt) x ResTyH98
 124                                 c -> panic "ForallC: Can't happen"
 125     mk_arg (IsStrict, ty)  = L loc $ HsBangTy HsStrict (cvtType loc ty)
 126     mk_arg (NotStrict, ty) = cvtType loc ty
 127
 128     mk_id_arg (i, IsStrict, ty)
 129         = (L loc (vName i), L loc $ HsBangTy HsStrict (cvtType loc ty))
 130     mk_id_arg (i, NotStrict, ty)
 131         = (L loc (vName i), cvtType loc ty)
 132
 133 mk_derivs loc [] = Nothing
 134 mk_derivs loc cs = Just [L loc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
 135
 136 cvt_fundep :: FunDep -> Class.FunDep RdrName
 137 cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
 138
 139 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 140 parse_ccall_impent nm s
 141  = case lex_ccall_impent s of
 142        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 143        Just ["wrapper"] -> Just (nilFS, CWrapper)
 144        Just ("static":ts) -> parse_ccall_impent_static nm ts
 145        Just ts -> parse_ccall_impent_static nm ts
 146        Nothing -> Nothing
 147
 148 parse_ccall_impent_static :: String
 149                           -> [String]
 150                           -> Maybe (FastString, CImportSpec)
 151 parse_ccall_impent_static nm ts
 152  = let ts' = case ts of
 153                  [       "&", cid] -> [       cid]
 154                  [fname, "&"     ] -> [fname     ]
 155                  [fname, "&", cid] -> [fname, cid]
 156                  _                 -> ts
 157    in case ts' of
 158           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
 159           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
 160           [          ]              -> Just (nilFS,              mk_cid nm)
 161           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
 162           _                         -> Nothing
 163     where is_cid :: String -> Bool
 164           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 165           mk_cid :: String -> CImportSpec
 166           mk_cid  = CFunction . StaticTarget . mkFastString
 167
 168 lex_ccall_impent :: String -> Maybe [String]
 169 lex_ccall_impent "" = Just []
 170 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 171 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 172 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 173 lex_ccall_impent xs = case span is_valid xs of
 174                           ("", _) -> Nothing
 175                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 176     where is_valid :: Char -> Bool
 177           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 178
 179 noContext loc  = L loc []
 180 noExistentials = []
 181
 182 -------------------------------------------------------------------
 183 convertToHsExpr :: SrcSpan -> TH.Exp -> LHsExpr RdrName
 184 convertToHsExpr loc e = cvtl loc e
 185
 186 cvtl loc e = cvt_l e
 187   where
 188     cvt_l e = L loc (cvt e)
 189
 190     cvt (VarE s)        = HsVar (vName s)
 191     cvt (ConE s)        = HsVar (cName s)
 192     cvt (LitE l)
 193       | overloadedLit l = HsOverLit (cvtOverLit l)
 194       | otherwise       = HsLit (cvtLit l)
 195
 196     cvt (AppE x y)     = HsApp (cvt_l x) (cvt_l y)
 197     cvt (LamE ps e)    = HsLam (mkMatchGroup [mkSimpleMatch (map (cvtlp loc) ps) (cvtl loc e)])
 198     cvt (TupE [e])     = cvt e
 199     cvt (TupE es)      = ExplicitTuple(map cvt_l es) Boxed
 200     cvt (CondE x y z)  = HsIf (cvt_l x) (cvt_l y) (cvt_l z)
 201     cvt (LetE ds e)        = HsLet (cvtdecs loc ds) (cvt_l e)
 202     cvt (CaseE e ms)   = HsCase (cvt_l e) (mkMatchGroup (map (cvtm loc) ms))
 203     cvt (DoE ss)       = cvtHsDo loc DoExpr ss
 204     cvt (CompE ss)     = cvtHsDo loc ListComp ss
 205     cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd loc dd)
 206     cvt (ListE xs)     = ExplicitList void (map cvt_l xs)
 207     cvt (InfixE (Just x) s (Just y))
 208         = HsPar (L loc $ OpApp (cvt_l x) (cvt_l s) undefined (cvt_l y))
 209     cvt (InfixE Nothing  s (Just y)) = SectionR (cvt_l s) (cvt_l y)
 210     cvt (InfixE (Just x) s Nothing ) = SectionL (cvt_l x) (cvt_l s)
 211     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 212     cvt (SigE e t)              = ExprWithTySig (cvt_l e) (cvtType loc t)
 213     cvt (RecConE c flds) = RecordCon (L loc (cName c)) noPostTcExpr
 214                                  (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
 215     cvt (RecUpdE e flds) = RecordUpd (cvt_l e) (map (\(x,y) -> (L loc (vName x), cvt_l y)) flds)
 216                                  placeHolderType placeHolderType
 217
 218 cvtHsDo loc do_or_lc stmts
 219   = HsDo do_or_lc (init stmts') body void
 220   where
 221     stmts' = cvtstmts loc stmts
 222     body = case last stmts' of
 223                 L _ (ExprStmt body _ _) -> body
 224
 225 cvtdecs :: SrcSpan -> [TH.Dec] -> HsLocalBinds RdrName
 226 cvtdecs loc [] = EmptyLocalBinds
 227 cvtdecs loc ds = HsValBinds (ValBindsIn binds sigs)
 228            where
 229              (binds, sigs) = cvtBindsAndSigs loc ds
 230
 231 cvtBindsAndSigs loc ds
 232   = (cvtds loc non_sigs, map (cvtSig loc) sigs)
 233   where
 234     (sigs, non_sigs) = partition sigP ds
 235
 236 cvtSig loc (TH.SigD nm typ) = L loc (Hs.TypeSig (L loc (vName nm)) (cvtType loc typ))
 237
 238 cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
 239 cvtds loc []     = emptyBag
 240 cvtds loc (d:ds) = cvtd loc d `consBag` cvtds loc ds
 241
 242 cvtd :: SrcSpan -> TH.Dec -> LHsBind RdrName
 243 -- Used only for declarations in a 'let/where' clause,
 244 -- not for top level decls
 245 cvtd loc (TH.ValD (TH.VarP s) body ds)
 246   = L loc $ FunBind (L loc (vName s)) False
 247                     (mkMatchGroup [cvtclause loc (Clause [] body ds)])
 248                     placeHolderNames
 249 cvtd loc (FunD nm cls)
 250   = L loc $ FunBind (L loc (vName nm)) False
 251                     (mkMatchGroup (map (cvtclause loc) cls))
 252                     placeHolderNames
 253 cvtd loc (TH.ValD p body ds)
 254   = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds))
 255                     void placeHolderNames
 256
 257 cvtd loc d = cvtPanic "Illegal kind of declaration in where clause"
 258                   (text (TH.pprint d))
 259
 260
 261 cvtclause :: SrcSpan -> TH.Clause -> Hs.LMatch RdrName
 262 cvtclause loc (Clause ps body wheres)
 263     = L loc $ Hs.Match (map (cvtlp loc) ps) Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres))
 264
 265
 266
 267 cvtdd :: SrcSpan -> Range -> ArithSeqInfo RdrName
 268 cvtdd loc (FromR x)           = (From (cvtl loc x))
 269 cvtdd loc (FromThenR x y)     = (FromThen (cvtl loc x) (cvtl loc y))
 270 cvtdd loc (FromToR x y)       = (FromTo (cvtl loc x) (cvtl loc y))
 271 cvtdd loc (FromThenToR x y z) = (FromThenTo (cvtl loc x) (cvtl loc y) (cvtl loc z))
 272
 273
 274 cvtstmts :: SrcSpan -> [TH.Stmt] -> [Hs.LStmt RdrName]
 275 cvtstmts loc []              = []
 276 cvtstmts loc (NoBindS e : ss)    = L loc (mkExprStmt (cvtl loc e))           : cvtstmts loc ss
 277 cvtstmts loc (TH.BindS p e : ss) = L loc (mkBindStmt (cvtlp loc p) (cvtl loc e)) : cvtstmts loc ss
 278 cvtstmts loc (TH.LetS ds : ss)   = L loc (LetStmt (cvtdecs loc ds))          : cvtstmts loc ss
 279 cvtstmts loc (TH.ParS dss : ss)  = L loc (ParStmt [(cvtstmts loc ds, undefined) | ds <- dss]) : cvtstmts loc ss
 280
 281 cvtm :: SrcSpan -> TH.Match -> Hs.LMatch RdrName
 282 cvtm loc (TH.Match p body wheres)
 283     = L loc (Hs.Match [cvtlp loc p] Nothing (GRHSs (cvtguard loc body) (cvtdecs loc wheres)))
 284
 285 cvtguard :: SrcSpan -> TH.Body -> [LGRHS RdrName]
 286 cvtguard loc (GuardedB pairs) = map (cvtpair loc) pairs
 287 cvtguard loc (NormalB e)      = [L loc (GRHS [] (cvtl loc e))]
 288
 289 cvtpair :: SrcSpan -> (TH.Guard,TH.Exp) -> LGRHS RdrName
 290 cvtpair loc (NormalG x,y) = L loc (GRHS [L loc $ mkBindStmt truePat (cvtl loc x)]
 291                                     (cvtl loc y))
 292 cvtpair loc (PatG x,y) = L loc (GRHS (cvtstmts loc x) (cvtl loc y))
 293
 294 cvtOverLit :: Lit -> HsOverLit RdrName
 295 cvtOverLit (IntegerL i)  = mkHsIntegral i
 296 cvtOverLit (RationalL r) = mkHsFractional r
 297 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 298 -- Similarly 3.5 for fractionals
 299
 300 cvtLit :: Lit -> HsLit
 301 cvtLit (IntPrimL i)    = HsIntPrim i
 302 cvtLit (FloatPrimL f)  = HsFloatPrim f
 303 cvtLit (DoublePrimL f) = HsDoublePrim f
 304 cvtLit (CharL c)       = HsChar c
 305 cvtLit (StringL s)     = HsString (mkFastString s)
 306
 307 cvtlp :: SrcSpan -> TH.Pat -> Hs.LPat RdrName
 308 cvtlp loc pat = L loc (cvtp loc pat)
 309
 310 cvtp :: SrcSpan -> TH.Pat -> Hs.Pat RdrName
 311 cvtp loc (TH.LitP l)
 312   | overloadedLit l = mkNPat (cvtOverLit l) Nothing     -- Not right for negative
 313                                                         -- patterns; need to think
 314                                                         -- about that!
 315   | otherwise       = Hs.LitPat (cvtLit l)
 316 cvtp loc (TH.VarP s)  = Hs.VarPat(vName s)
 317 cvtp loc (TupP [p])   = cvtp loc p
 318 cvtp loc (TupP ps)    = TuplePat (map (cvtlp loc) ps) Boxed
 319 cvtp loc (ConP s ps)  = ConPatIn (L loc (cName s)) (PrefixCon (map (cvtlp loc) ps))
 320 cvtp loc (InfixP p1 s p2)
 321                   = ConPatIn (L loc (cName s)) (InfixCon (cvtlp loc p1) (cvtlp loc p2))
 322 cvtp loc (TildeP p)   = LazyPat (cvtlp loc p)
 323 cvtp loc (TH.AsP s p) = AsPat (L loc (vName s)) (cvtlp loc p)
 324 cvtp loc TH.WildP   = WildPat void
 325 cvtp loc (RecP c fs)  = ConPatIn (L loc (cName c)) $ Hs.RecCon (map (\(s,p) -> (L loc (vName s),cvtlp loc p)) fs)
 326 cvtp loc (ListP ps)   = ListPat (map (cvtlp loc) ps) void
 327 cvtp loc (SigP p t)   = SigPatIn (cvtlp loc p) (cvtType loc t)
 328
 329 -----------------------------------------------------------
 330 --      Types and type variables
 331
 332 cvt_tvs :: SrcSpan -> [TH.Name] -> [LHsTyVarBndr RdrName]
 333 cvt_tvs loc tvs = map (L loc . UserTyVar . tName) tvs
 334
 335 cvt_context :: SrcSpan -> Cxt -> LHsContext RdrName
 336 cvt_context loc tys = L loc (map (L loc . cvt_pred loc) tys)
 337
 338 cvt_pred :: SrcSpan -> TH.Type -> HsPred RdrName
 339 cvt_pred loc ty
 340   = case split_ty_app ty of
 341         (ConT tc, tys) -> HsClassP (tconName tc) (map (cvtType loc) tys)
 342         (VarT tv, tys) -> HsClassP (tName tv) (map (cvtType loc) tys)
 343         other -> cvtPanic "Malformed predicate" (text (TH.pprint ty))
 344
 345 convertToHsType = cvtType
 346
 347 cvtType :: SrcSpan -> TH.Type -> LHsType RdrName
 348 cvtType loc ty = trans (root ty [])
 349   where root (AppT a b) zs = root a (cvtType loc b : zs)
 350         root t zs          = (t,zs)
 351
 352         trans (TupleT n,args)
 353             | length args == n = L loc (HsTupleTy Boxed args)
 354             | n == 0    = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon))        args
 355             | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args
 356         trans (ArrowT,   [x,y]) = nlHsFunTy x y
 357         trans (ListT,    [x])   = L loc (HsListTy x)
 358
 359         trans (VarT nm, args)       = foldl nlHsAppTy (nlHsTyVar (tName nm))    args
 360         trans (ConT tc, args)       = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args
 361
 362         trans (ForallT tvs cxt ty, []) = L loc $ mkExplicitHsForAllTy
 363                                                 (cvt_tvs loc tvs) (cvt_context loc cxt) (cvtType loc ty)
 364
 365 split_ty_app :: TH.Type -> (TH.Type, [TH.Type])
 366 split_ty_app ty = go ty []
 367   where
 368     go (AppT f a) as = go f (a:as)
 369     go f as          = (f,as)
 370
 371 -----------------------------------------------------------
 372 sigP :: Dec -> Bool
 373 sigP (TH.SigD _ _) = True
 374 sigP other       = False
 375
 376
 377 -----------------------------------------------------------
 378 cvtPanic :: String -> SDoc -> b
 379 cvtPanic herald thing
 380   = pprPanic herald (thing $$ ptext SLIT("When splicing generated code into the program"))
 381
 382 -----------------------------------------------------------
 383 -- some useful things
 384
 385 truePat  = nlConPat (getRdrName trueDataCon)  []
 386
 387 overloadedLit :: Lit -> Bool
 388 -- True for literals that Haskell treats as overloaded
 389 overloadedLit (IntegerL  l) = True
 390 overloadedLit (RationalL l) = True
 391 overloadedLit l             = False
 392
 393 void :: Type.Type
 394 void = placeHolderType
 395
 396 --------------------------------------------------------------------
 397 --      Turning Name back into RdrName
 398 --------------------------------------------------------------------
 399
 400 -- variable names
 401 vName :: TH.Name -> RdrName
 402 vName = thRdrName OccName.varName
 403
 404 -- Constructor function names; this is Haskell source, hence srcDataName
 405 cName :: TH.Name -> RdrName
 406 cName = thRdrName OccName.srcDataName
 407
 408 -- Type variable names
 409 tName :: TH.Name -> RdrName
 410 tName = thRdrName OccName.tvName
 411
 412 -- Type Constructor names
 413 tconName = thRdrName OccName.tcName
 414
 415 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
 416 -- This turns a Name into a RdrName
 417 -- The passed-in name space tells what the context is expecting;
 418 --      use it unless the TH name knows what name-space it comes
 419 --      from, in which case use the latter
 420 thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig      (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
 421 thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq))      = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
 422 thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod))       = mkRdrQual   (mk_mod mod) (mk_occ ctxt_ns occ)
 423 thRdrName ctxt_ns (TH.Name occ TH.NameS)             = mkRdrUnqual (mk_occ ctxt_ns occ)
 424 thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq))      = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
 425
 426 mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
 427 mk_uniq_occ ns occ uniq
 428   = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
 429         -- The idea here is to make a name that
 430         -- a) the user could not possibly write, and
 431         -- b) cannot clash with another NameU
 432         -- Previously I generated an Exact RdrName with mkInternalName.
 433         -- This works fine for local binders, but does not work at all for
 434         -- top-level binders, which must have External Names, since they are
 435         -- rapidly baked into data constructors and the like.  Baling out
 436         -- and generating an unqualified RdrName here is the simple solution
 437
 438 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 439 mk_ghc_ns DataName     = OccName.dataName
 440 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 441 mk_ghc_ns TH.VarName   = OccName.varName
 442
 443 -- The packing and unpacking is rather turgid :-(
 444 mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
 445 mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
 446
 447 mk_mod :: TH.ModName -> Module
 448 mk_mod mod = mkModule (TH.modString mod)
 449
 450 mk_uniq :: Int# -> Unique
 451 mk_uniq u = mkUniqueGrimily (I# u)
 452 \end{code}
 453