compiler/deSugar/DsMeta.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2006
   4 --
   5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
   6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
   7 -- input HsExpr. We do this in the DsM monad, which supplies access to
   8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
   9 --
  10 -- It also defines a bunch of knownKeyNames, in the same way as is done
  11 -- in prelude/PrelNames.  It's much more convenient to do it here, becuase
  12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
  13 -- a Royal Pain (triggers other recompilation).
  14 -----------------------------------------------------------------------------
  15
  16 {-# OPTIONS -fno-warn-unused-imports #-}
  17 -- The above warning supression flag is a temporary kludge.
  18 -- While working on this module you are encouraged to remove it and fix
  19 -- any warnings in the module. See
  20 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  21 -- for details
  22 -- The kludge is only needed in this module because of trac #2267.
  23
  24 module DsMeta( dsBracket,
  25                templateHaskellNames, qTyConName, nameTyConName,
  26                liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
  27                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
  28                quoteExpName, quotePatName
  29                 ) where
  30
  31 #include "HsVersions.h"
  32
  33 import {-# SOURCE #-}   DsExpr ( dsExpr )
  34
  35 import MatchLit
  36 import DsUtils
  37 import DsMonad
  38
  39 import qualified Language.Haskell.TH as TH
  40
  41 import HsSyn
  42 import Class
  43 import PrelNames
  44 -- To avoid clashes with DsMeta.varName we must make a local alias for
  45 -- OccName.varName we do this by removing varName from the import of
  46 -- OccName above, making a qualified instance of OccName and using
  47 -- OccNameAlias.varName where varName ws previously used in this file.
  48 import qualified OccName
  49
  50 import Module
  51 import Id
  52 import Name
  53 import NameEnv
  54 import TcType
  55 import TyCon
  56 import TysWiredIn
  57 import CoreSyn
  58 import MkCore
  59 import CoreUtils
  60 import SrcLoc
  61 import Unique
  62 import BasicTypes
  63 import Outputable
  64 import Bag
  65 import FastString
  66 import ForeignCall
  67 import MonadUtils
  68
  69 import Data.Maybe
  70 import Control.Monad
  71 import Data.List
  72
  73 -----------------------------------------------------------------------------
  74 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  75 -- Returns a CoreExpr of type TH.ExpQ
  76 -- The quoted thing is parameterised over Name, even though it has
  77 -- been type checked.  We don't want all those type decorations!
  78
  79 dsBracket brack splices
  80   = dsExtendMetaEnv new_bit (do_brack brack)
  81   where
  82     new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
  83
  84     do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
  85     do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
  86     do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
  87     do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
  88     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
  89
  90 {- -------------- Examples --------------------
  91
  92   [| \x -> x |]
  93 ====>
  94   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  95   lam (pvar x1) (var x1)
  96
  97
  98   [| \x -> $(f [| x |]) |]
  99 ====>
 100   gensym (unpackString "x"#) `bindQ` \ x1::String ->
 101   lam (pvar x1) (f (var x1))
 102 -}
 103
 104
 105 -------------------------------------------------------
 106 --                      Declarations
 107 -------------------------------------------------------
 108
 109 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 110 repTopDs group
 111  = do { let { bndrs = map unLoc (groupBinders group) } ;
 112         ss <- mkGenSyms bndrs ;
 113
 114         -- Bind all the names mainly to avoid repeated use of explicit strings.
 115         -- Thus we get
 116         --      do { t :: String <- genSym "T" ;
 117         --           return (Data t [] ...more t's... }
 118         -- The other important reason is that the output must mention
 119         -- only "T", not "Foo:T" where Foo is the current module
 120
 121
 122         decls <- addBinds ss (do {
 123                         val_ds  <- rep_val_binds (hs_valds group) ;
 124                         tycl_ds <- mapM repTyClD (hs_tyclds group) ;
 125                         inst_ds <- mapM repInstD' (hs_instds group) ;
 126                         for_ds <- mapM repForD (hs_fords group) ;
 127                         -- more needed
 128                         return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
 129
 130         decl_ty <- lookupType decQTyConName ;
 131         let { core_list = coreList' decl_ty decls } ;
 132
 133         dec_ty <- lookupType decTyConName ;
 134         q_decs  <- repSequenceQ dec_ty core_list ;
 135
 136         wrapNongenSyms ss q_decs
 137         -- Do *not* gensym top-level binders
 138       }
 139
 140 groupBinders :: HsGroup Name -> [Located Name]
 141 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 142                         hs_instds = inst_decls, hs_fords = foreign_decls })
 143 -- Collect the binders of a Group
 144   = collectHsValBinders val_decls ++
 145     [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
 146     [n | L _ (ForeignImport n _ _) <- foreign_decls]
 147   where
 148     assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
 149
 150
 151 {-      Note [Binders and occurrences]
 152         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 153 When we desugar [d| data T = MkT |]
 154 we want to get
 155         Data "T" [] [Con "MkT" []] []
 156 and *not*
 157         Data "Foo:T" [] [Con "Foo:MkT" []] []
 158 That is, the new data decl should fit into whatever new module it is
 159 asked to fit in.   We do *not* clone, though; no need for this:
 160         Data "T79" ....
 161
 162 But if we see this:
 163         data T = MkT
 164         foo = reifyDecl T
 165
 166 then we must desugar to
 167         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
 168
 169 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
 170 And we use lookupOcc, rather than lookupBinder
 171 in repTyClD and repC.
 172
 173 -}
 174
 175 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 176
 177 repTyClD tydecl@(L _ (TyFamily {}))
 178   = repTyFamily tydecl addTyVarBinds
 179
 180 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
 181                           tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 182                           tcdCons = cons, tcdDerivs = mb_derivs }))
 183   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 184        ; dec <- addTyVarBinds tvs $ \bndrs ->
 185            do { cxt1     <- repLContext cxt
 186               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 187               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 188               ; cons1    <- mapM repC cons
 189               ; cons2    <- coreList conQTyConName cons1
 190               ; derivs1  <- repDerivs mb_derivs
 191               ; bndrs1   <- coreList nameTyConName bndrs
 192               ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
 193               }
 194        ; return $ Just (loc, dec)
 195        }
 196
 197 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
 198                           tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 199                           tcdCons = [con], tcdDerivs = mb_derivs }))
 200   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 201        ; dec <- addTyVarBinds tvs $ \bndrs ->
 202            do { cxt1     <- repLContext cxt
 203               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 204               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 205               ; con1     <- repC con
 206               ; derivs1  <- repDerivs mb_derivs
 207               ; bndrs1   <- coreList nameTyConName bndrs
 208               ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
 209               }
 210        ; return $ Just (loc, dec)
 211        }
 212
 213 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 214                              tcdSynRhs = ty }))
 215   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 216        ; dec <- addTyVarBinds tvs $ \bndrs ->
 217            do { opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 218               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 219               ; ty1      <- repLTy ty
 220               ; bndrs1   <- coreList nameTyConName bndrs
 221               ; repTySyn tc1 bndrs1 opt_tys2 ty1
 222               }
 223        ; return (Just (loc, dec))
 224        }
 225
 226 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
 227                              tcdTyVars = tvs, tcdFDs = fds,
 228                              tcdSigs = sigs, tcdMeths = meth_binds,
 229                              tcdATs = ats }))
 230   = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
 231        ; dec  <- addTyVarBinds tvs $ \bndrs ->
 232            do { cxt1   <- repLContext cxt
 233               ; sigs1  <- rep_sigs sigs
 234               ; binds1 <- rep_binds meth_binds
 235               ; fds1   <- repLFunDeps fds
 236               ; ats1   <- repLAssocFamilys ats
 237               ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
 238               ; bndrs1 <- coreList nameTyConName bndrs
 239               ; repClass cxt1 cls1 bndrs1 fds1 decls1
 240               }
 241        ; return $ Just (loc, dec)
 242        }
 243
 244 -- Un-handled cases
 245 repTyClD (L loc d) = putSrcSpanDs loc $
 246                      do { warnDs (hang ds_msg 4 (ppr d))
 247                         ; return Nothing }
 248
 249 -- The type variables in the head of families are treated differently when the
 250 -- family declaration is associated.  In that case, they are usage, not binding
 251 -- occurences.
 252 --
 253 repTyFamily :: LTyClDecl Name
 254             -> ProcessTyVarBinds TH.Dec
 255             -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 256 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
 257                                tcdLName = tc, tcdTyVars = tvs,
 258                                tcdKind = _kind }))
 259             tyVarBinds
 260   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 261        ; dec <- tyVarBinds tvs $ \bndrs ->
 262            do { flav   <- repFamilyFlavour flavour
 263               ; bndrs1 <- coreList nameTyConName bndrs
 264               ; repFamily flav tc1 bndrs1
 265               }
 266        ; return $ Just (loc, dec)
 267        }
 268 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
 269
 270 -- represent fundeps
 271 --
 272 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
 273 repLFunDeps fds = do fds' <- mapM repLFunDep fds
 274                      fdList <- coreList funDepTyConName fds'
 275                      return fdList
 276
 277 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
 278 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
 279                                ys' <- mapM lookupBinder ys
 280                                xs_list <- coreList nameTyConName xs'
 281                                ys_list <- coreList nameTyConName ys'
 282                                repFunDep xs_list ys_list
 283
 284 -- represent family declaration flavours
 285 --
 286 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
 287 repFamilyFlavour TypeFamily = rep2 typeFamName []
 288 repFamilyFlavour DataFamily = rep2 dataFamName []
 289
 290 -- represent associated family declarations
 291 --
 292 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
 293 repLAssocFamilys = mapM repLAssocFamily
 294   where
 295     repLAssocFamily tydecl@(L _ (TyFamily {}))
 296       = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
 297     repLAssocFamily tydecl
 298       = failWithDs msg
 299       where
 300         msg = ptext (sLit "Illegal associated declaration in class:") <+>
 301               ppr tydecl
 302
 303 -- represent associated family instances
 304 --
 305 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
 306 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
 307
 308 -- represent instance declarations
 309 --
 310 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 311 repInstD' (L loc (InstDecl ty binds _ ats))     -- Ignore user pragmas for now
 312   = do { i <- addTyVarBinds tvs $ \_ ->
 313                 -- We must bring the type variables into scope, so their
 314                 -- occurrences don't fail, even though the binders don't
 315                 -- appear in the resulting data structure
 316                 do { cxt1 <- repContext cxt
 317                    ; inst_ty1 <- repPredTy (HsClassP cls tys)
 318                    ; ss <- mkGenSyms (collectHsBindBinders binds)
 319                    ; binds1 <- addBinds ss (rep_binds binds)
 320                    ; ats1   <- repLAssocFamInst ats
 321                    ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
 322                    ; decls2 <- wrapNongenSyms ss decls1
 323                    -- wrapNongenSyms: do not clone the class op names!
 324                    -- They must be called 'op' etc, not 'op34'
 325                    ; repInst cxt1 inst_ty1 (decls2)
 326                    }
 327         ; return (loc, i)}
 328  where
 329    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 330
 331 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 332 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
 333  = do MkC name' <- lookupLOcc name
 334       MkC typ' <- repLTy typ
 335       MkC cc' <- repCCallConv cc
 336       MkC s' <- repSafety s
 337       cis' <- conv_cimportspec cis
 338       MkC str <- coreStringLit $ static
 339                               ++ unpackFS ch ++ " "
 340                               ++ unpackFS cn ++ " "
 341                               ++ cis'
 342       dec <- rep2 forImpDName [cc', s', str, name', typ']
 343       return (loc, dec)
 344  where
 345     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
 346     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
 347     conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
 348     conv_cimportspec CWrapper = return "wrapper"
 349     static = case cis of
 350                  CFunction (StaticTarget _) -> "static "
 351                  _ -> ""
 352 repForD decl = notHandled "Foreign declaration" (ppr decl)
 353
 354 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
 355 repCCallConv CCallConv = rep2 cCallName []
 356 repCCallConv StdCallConv = rep2 stdCallName []
 357 repCCallConv CmmCallConv = notHandled "repCCallConv" (ppr CmmCallConv)
 358
 359 repSafety :: Safety -> DsM (Core TH.Safety)
 360 repSafety PlayRisky = rep2 unsafeName []
 361 repSafety (PlaySafe False) = rep2 safeName []
 362 repSafety (PlaySafe True) = rep2 threadsafeName []
 363
 364 ds_msg :: SDoc
 365 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 366
 367 -------------------------------------------------------
 368 --                      Constructors
 369 -------------------------------------------------------
 370
 371 repC :: LConDecl Name -> DsM (Core TH.ConQ)
 372 repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _))
 373   = do { con1 <- lookupLOcc con ;               -- See note [Binders and occurrences]
 374          repConstr con1 details }
 375 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
 376   = do { addTyVarBinds tvs $ \bndrs -> do {
 377              c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
 378              ctxt' <- repContext ctxt;
 379              bndrs' <- coreList nameTyConName bndrs;
 380              rep2 forallCName [unC bndrs', unC ctxt', unC c']
 381          }
 382        }
 383 repC (L loc con_decl)           -- GADTs
 384   = putSrcSpanDs loc $
 385     notHandled "GADT declaration" (ppr con_decl)
 386
 387 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 388 repBangTy ty= do
 389   MkC s <- rep2 str []
 390   MkC t <- repLTy ty'
 391   rep2 strictTypeName [s, t]
 392   where
 393     (str, ty') = case ty of
 394                    L _ (HsBangTy _ ty) -> (isStrictName,  ty)
 395                    _                   -> (notStrictName, ty)
 396
 397 -------------------------------------------------------
 398 --                      Deriving clause
 399 -------------------------------------------------------
 400
 401 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
 402 repDerivs Nothing = coreList nameTyConName []
 403 repDerivs (Just ctxt)
 404   = do { strs <- mapM rep_deriv ctxt ;
 405          coreList nameTyConName strs }
 406   where
 407     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
 408         -- Deriving clauses must have the simple H98 form
 409     rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
 410     rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
 411
 412
 413 -------------------------------------------------------
 414 --   Signatures in a class decl, or a group of bindings
 415 -------------------------------------------------------
 416
 417 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
 418 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
 419                    return $ de_loc $ sort_by_loc locs_cores
 420
 421 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
 422         -- We silently ignore ones we don't recognise
 423 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 424                      return (concat sigs1) }
 425
 426 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 427         -- Singleton => Ok
 428         -- Empty     => Too hard, signature ignored
 429 rep_sig (L loc (TypeSig nm ty))       = rep_proto nm ty loc
 430 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 431 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 432 rep_sig _                             = return []
 433
 434 rep_proto :: Located Name -> LHsType Name -> SrcSpan
 435           -> DsM [(SrcSpan, Core TH.DecQ)]
 436 rep_proto nm ty loc
 437   = do { nm1 <- lookupLOcc nm
 438        ; ty1 <- repLTy ty
 439        ; sig <- repProto nm1 ty1
 440        ; return [(loc, sig)]
 441        }
 442
 443 rep_inline :: Located Name -> InlineSpec -> SrcSpan
 444            -> DsM [(SrcSpan, Core TH.DecQ)]
 445 rep_inline nm ispec loc
 446   = do { nm1 <- lookupLOcc nm
 447        ; (_, ispec1) <- rep_InlineSpec ispec
 448        ; pragma <- repPragInl nm1 ispec1
 449        ; return [(loc, pragma)]
 450        }
 451
 452 rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan
 453                -> DsM [(SrcSpan, Core TH.DecQ)]
 454 rep_specialise nm ty ispec loc
 455   = do { nm1 <- lookupLOcc nm
 456        ; ty1 <- repLTy ty
 457        ; (hasSpec, ispec1) <- rep_InlineSpec ispec
 458        ; pragma <- if hasSpec
 459                    then repPragSpecInl nm1 ty1 ispec1
 460                    else repPragSpec    nm1 ty1
 461        ; return [(loc, pragma)]
 462        }
 463
 464 -- extract all the information needed to build a TH.InlineSpec
 465 --
 466 rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
 467 rep_InlineSpec (Inline (InlinePragma activation match) inline)
 468   | Nothing            <- activation1
 469     = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
 470   | Just (flag, phase) <- activation1
 471     = liftM ((,) True)  $ repInlineSpecPhase inline1 match1 flag phase
 472   | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
 473     where
 474       match1      = coreBool (rep_RuleMatchInfo match)
 475       activation1 = rep_Activation activation
 476       inline1     = coreBool inline
 477
 478       rep_RuleMatchInfo FunLike = False
 479       rep_RuleMatchInfo ConLike = True
 480
 481       rep_Activation NeverActive          = Nothing
 482       rep_Activation AlwaysActive         = Nothing
 483       rep_Activation (ActiveBefore phase) = Just (coreBool False,
 484                                                   MkC $ mkIntExprInt phase)
 485       rep_Activation (ActiveAfter phase)  = Just (coreBool True,
 486                                                   MkC $ mkIntExprInt phase)
 487
 488
 489 -------------------------------------------------------
 490 --                      Types
 491 -------------------------------------------------------
 492
 493 -- We process type variable bindings in two ways, either by generating fresh
 494 -- names or looking up existing names.  The difference is crucial for type
 495 -- families, depending on whether they are associated or not.
 496 --
 497 type ProcessTyVarBinds a =
 498          [LHsTyVarBndr Name]                     -- the binders to be added
 499       -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
 500       -> DsM (Core (TH.Q a))
 501
 502 -- gensym a list of type variables and enter them into the meta environment;
 503 -- the computations passed as the second argument is executed in that extended
 504 -- meta environment and gets the *new* names on Core-level as an argument
 505 --
 506 addTyVarBinds :: ProcessTyVarBinds a
 507 addTyVarBinds tvs m =
 508   do
 509     let names = map (hsTyVarName.unLoc) tvs
 510     freshNames <- mkGenSyms names
 511     term       <- addBinds freshNames $ do
 512                     bndrs <- mapM lookupBinder names
 513                     m bndrs
 514     wrapGenSyns freshNames term
 515
 516 -- Look up a list of type variables; the computations passed as the second
 517 -- argument gets the *new* names on Core-level as an argument
 518 --
 519 lookupTyVarBinds :: ProcessTyVarBinds a
 520 lookupTyVarBinds tvs m =
 521   do
 522     let names = map (hsTyVarName.unLoc) tvs
 523     bndrs <- mapM lookupBinder names
 524     m bndrs
 525
 526 -- represent a type context
 527 --
 528 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
 529 repLContext (L _ ctxt) = repContext ctxt
 530
 531 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 532 repContext ctxt = do
 533                     preds    <- mapM repLPred ctxt
 534                     predList <- coreList predQTyConName preds
 535                     repCtxt predList
 536
 537 -- represent a type predicate
 538 --
 539 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
 540 repLPred (L _ p) = repPred p
 541
 542 repPred :: HsPred Name -> DsM (Core TH.PredQ)
 543 repPred (HsClassP cls tys)
 544   = do
 545       cls1 <- lookupOcc cls
 546       tys1 <- repLTys tys
 547       tys2 <- coreList typeQTyConName tys1
 548       repClassP cls1 tys2
 549 repPred (HsEqualP tyleft tyright)
 550   = do
 551       tyleft1  <- repLTy tyleft
 552       tyright1 <- repLTy tyright
 553       repEqualP tyleft1 tyright1
 554 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 555
 556 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
 557 repPredTy (HsClassP cls tys)
 558   = do
 559       tcon <- repTy (HsTyVar cls)
 560       tys1 <- repLTys tys
 561       repTapps tcon tys1
 562 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
 563
 564 -- yield the representation of a list of types
 565 --
 566 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 567 repLTys tys = mapM repLTy tys
 568
 569 -- represent a type
 570 --
 571 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 572 repLTy (L _ ty) = repTy ty
 573
 574 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 575 repTy (HsForAllTy _ tvs ctxt ty)  =
 576   addTyVarBinds tvs $ \bndrs -> do
 577     ctxt1  <- repLContext ctxt
 578     ty1    <- repLTy ty
 579     bndrs1 <- coreList nameTyConName bndrs
 580     repTForall bndrs1 ctxt1 ty1
 581
 582 repTy (HsTyVar n)
 583   | isTvOcc (nameOccName n)       = do
 584                                       tv1 <- lookupTvOcc n
 585                                       repTvar tv1
 586   | otherwise                     = do
 587                                       tc1 <- lookupOcc n
 588                                       repNamedTyCon tc1
 589 repTy (HsAppTy f a)               = do
 590                                       f1 <- repLTy f
 591                                       a1 <- repLTy a
 592                                       repTapp f1 a1
 593 repTy (HsFunTy f a)               = do
 594                                       f1   <- repLTy f
 595                                       a1   <- repLTy a
 596                                       tcon <- repArrowTyCon
 597                                       repTapps tcon [f1, a1]
 598 repTy (HsListTy t)                = do
 599                                       t1   <- repLTy t
 600                                       tcon <- repListTyCon
 601                                       repTapp tcon t1
 602 repTy (HsPArrTy t)                = do
 603                                       t1   <- repLTy t
 604                                       tcon <- repTy (HsTyVar (tyConName parrTyCon))
 605                                       repTapp tcon t1
 606 repTy (HsTupleTy _ tys)   = do
 607                                       tys1 <- repLTys tys
 608                                       tcon <- repTupleTyCon (length tys)
 609                                       repTapps tcon tys1
 610 repTy (HsOpTy ty1 n ty2)          = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 611                                            `nlHsAppTy` ty2)
 612 repTy (HsParTy t)                 = repLTy t
 613 repTy (HsPredTy pred)             = repPredTy pred
 614 repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
 615 repTy ty                          = notHandled "Exotic form of type" (ppr ty)
 616
 617
 618 -----------------------------------------------------------------------------
 619 --              Expressions
 620 -----------------------------------------------------------------------------
 621
 622 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
 623 repLEs es = do { es'  <- mapM repLE es ;
 624                  coreList expQTyConName es' }
 625
 626 -- FIXME: some of these panics should be converted into proper error messages
 627 --        unless we can make sure that constructs, which are plainly not
 628 --        supported in TH already lead to error messages at an earlier stage
 629 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
 630 repLE (L loc e) = putSrcSpanDs loc (repE e)
 631
 632 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 633 repE (HsVar x)            =
 634   do { mb_val <- dsLookupMetaEnv x
 635      ; case mb_val of
 636         Nothing          -> do { str <- globalVar x
 637                                ; repVarOrCon x str }
 638         Just (Bound y)   -> repVarOrCon x (coreVar y)
 639         Just (Splice e)  -> do { e' <- dsExpr e
 640                                ; return (MkC e') } }
 641 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 642
 643         -- Remember, we're desugaring renamer output here, so
 644         -- HsOverlit can definitely occur
 645 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 646 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 647 repE (HsLam (MatchGroup [m] _)) = repLambda m
 648 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 649
 650 repE (OpApp e1 op _ e2) =
 651   do { arg1 <- repLE e1;
 652        arg2 <- repLE e2;
 653        the_op <- repLE op ;
 654        repInfixApp arg1 the_op arg2 }
 655 repE (NegApp x _)        = do
 656                               a         <- repLE x
 657                               negateVar <- lookupOcc negateName >>= repVar
 658                               negateVar `repApp` a
 659 repE (HsPar x)            = repLE x
 660 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 661 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 662 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 663                                        ; ms2 <- mapM repMatchTup ms
 664                                        ; repCaseE arg (nonEmptyCoreList ms2) }
 665 repE (HsIf x y z)         = do
 666                               a <- repLE x
 667                               b <- repLE y
 668                               c <- repLE z
 669                               repCond a b c
 670 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 671                                ; e2 <- addBinds ss (repLE e)
 672                                ; z <- repLetE ds e2
 673                                ; wrapGenSyns ss z }
 674 -- FIXME: I haven't got the types here right yet
 675 repE (HsDo DoExpr sts body _)
 676  = do { (ss,zs) <- repLSts sts;
 677         body'   <- addBinds ss $ repLE body;
 678         ret     <- repNoBindSt body';
 679         e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
 680         wrapGenSyns ss e }
 681 repE (HsDo ListComp sts body _)
 682  = do { (ss,zs) <- repLSts sts;
 683         body'   <- addBinds ss $ repLE body;
 684         ret     <- repNoBindSt body';
 685         e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
 686         wrapGenSyns ss e }
 687 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
 688 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 689 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 690 repE e@(ExplicitTuple es boxed)
 691   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
 692   | otherwise             = notHandled "Unboxed tuples" (ppr e)
 693 repE (RecordCon c _ flds)
 694  = do { x <- lookupLOcc c;
 695         fs <- repFields flds;
 696         repRecCon x fs }
 697 repE (RecordUpd e flds _ _ _)
 698  = do { x <- repLE e;
 699         fs <- repFields flds;
 700         repRecUpd x fs }
 701
 702 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
 703 repE (ArithSeq _ aseq) =
 704   case aseq of
 705     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 706     FromThen e1 e2      -> do
 707                              ds1 <- repLE e1
 708                              ds2 <- repLE e2
 709                              repFromThen ds1 ds2
 710     FromTo   e1 e2      -> do
 711                              ds1 <- repLE e1
 712                              ds2 <- repLE e2
 713                              repFromTo ds1 ds2
 714     FromThenTo e1 e2 e3 -> do
 715                              ds1 <- repLE e1
 716                              ds2 <- repLE e2
 717                              ds3 <- repLE e3
 718                              repFromThenTo ds1 ds2 ds3
 719 repE (HsSpliceE (HsSplice n _))
 720   = do { mb_val <- dsLookupMetaEnv n
 721        ; case mb_val of
 722                  Just (Splice e) -> do { e' <- dsExpr e
 723                                        ; return (MkC e') }
 724                  _ -> pprPanic "HsSplice" (ppr n) }
 725                         -- Should not happen; statically checked
 726
 727 repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
 728 repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
 729 repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
 730 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
 731 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
 732 repE e                   = notHandled "Expression form" (ppr e)
 733
 734 -----------------------------------------------------------------------------
 735 -- Building representations of auxillary structures like Match, Clause, Stmt,
 736
 737 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
 738 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
 739   do { ss1 <- mkGenSyms (collectPatBinders p)
 740      ; addBinds ss1 $ do {
 741      ; p1 <- repLP p
 742      ; (ss2,ds) <- repBinds wheres
 743      ; addBinds ss2 $ do {
 744      ; gs    <- repGuards guards
 745      ; match <- repMatch p1 gs ds
 746      ; wrapGenSyns (ss1++ss2) match }}}
 747 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 748
 749 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
 750 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
 751   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 752      ; addBinds ss1 $ do {
 753        ps1 <- repLPs ps
 754      ; (ss2,ds) <- repBinds wheres
 755      ; addBinds ss2 $ do {
 756        gs <- repGuards guards
 757      ; clause <- repClause ps1 gs ds
 758      ; wrapGenSyns (ss1++ss2) clause }}}
 759
 760 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 761 repGuards [L _ (GRHS [] e)]
 762   = do {a <- repLE e; repNormal a }
 763 repGuards other
 764   = do { zs <- mapM process other;
 765      let {(xs, ys) = unzip zs};
 766          gd <- repGuarded (nonEmptyCoreList ys);
 767      wrapGenSyns (concat xs) gd }
 768   where
 769     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
 770     process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
 771            = do { x <- repLNormalGE e1 e2;
 772                   return ([], x) }
 773     process (L _ (GRHS ss rhs))
 774            = do (gs, ss') <- repLSts ss
 775                 rhs' <- addBinds gs $ repLE rhs
 776                 g <- repPatGE (nonEmptyCoreList ss') rhs'
 777                 return (gs, g)
 778
 779 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 780 repFields (HsRecFields { rec_flds = flds })
 781   = do  { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
 782         ; es <- mapM repLE (map hsRecFieldArg flds)
 783         ; fs <- zipWithM repFieldExp fnames es
 784         ; coreList fieldExpQTyConName fs }
 785
 786
 787 -----------------------------------------------------------------------------
 788 -- Representing Stmt's is tricky, especially if bound variables
 789 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 790 -- First gensym new names for every variable in any of the patterns.
 791 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 792 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 793 -- and we could reuse the original names (x and x).
 794 --
 795 -- do { x'1 <- gensym "x"
 796 --    ; x'2 <- gensym "x"
 797 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 798 --          , BindSt (pvar x'2) [| f x |]
 799 --          , NoBindSt [| g x |]
 800 --          ]
 801 --    }
 802
 803 -- The strategy is to translate a whole list of do-bindings by building a
 804 -- bigger environment, and a bigger set of meta bindings
 805 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 806 -- of the expressions within the Do
 807
 808 -----------------------------------------------------------------------------
 809 -- The helper function repSts computes the translation of each sub expression
 810 -- and a bunch of prefix bindings denoting the dynamic renaming.
 811
 812 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 813 repLSts stmts = repSts (map unLoc stmts)
 814
 815 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 816 repSts (BindStmt p e _ _ : ss) =
 817    do { e2 <- repLE e
 818       ; ss1 <- mkGenSyms (collectPatBinders p)
 819       ; addBinds ss1 $ do {
 820       ; p1 <- repLP p;
 821       ; (ss2,zs) <- repSts ss
 822       ; z <- repBindSt p1 e2
 823       ; return (ss1++ss2, z : zs) }}
 824 repSts (LetStmt bs : ss) =
 825    do { (ss1,ds) <- repBinds bs
 826       ; z <- repLetSt ds
 827       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 828       ; return (ss1++ss2, z : zs) }
 829 repSts (ExprStmt e _ _ : ss) =
 830    do { e2 <- repLE e
 831       ; z <- repNoBindSt e2
 832       ; (ss2,zs) <- repSts ss
 833       ; return (ss2, z : zs) }
 834 repSts []    = return ([],[])
 835 repSts other = notHandled "Exotic statement" (ppr other)
 836
 837
 838 -----------------------------------------------------------
 839 --                      Bindings
 840 -----------------------------------------------------------
 841
 842 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 843 repBinds EmptyLocalBinds
 844   = do  { core_list <- coreList decQTyConName []
 845         ; return ([], core_list) }
 846
 847 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
 848
 849 repBinds (HsValBinds decs)
 850  = do   { let { bndrs = map unLoc (collectHsValBinders decs) }
 851                 -- No need to worrry about detailed scopes within
 852                 -- the binding group, because we are talking Names
 853                 -- here, so we can safely treat it as a mutually
 854                 -- recursive group
 855         ; ss        <- mkGenSyms bndrs
 856         ; prs       <- addBinds ss (rep_val_binds decs)
 857         ; core_list <- coreList decQTyConName
 858                                 (de_loc (sort_by_loc prs))
 859         ; return (ss, core_list) }
 860
 861 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 862 -- Assumes: all the binders of the binding are alrady in the meta-env
 863 rep_val_binds (ValBindsOut binds sigs)
 864  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
 865       ; core2 <- rep_sigs' sigs
 866       ; return (core1 ++ core2) }
 867 rep_val_binds (ValBindsIn _ _)
 868  = panic "rep_val_binds: ValBindsIn"
 869
 870 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 871 rep_binds binds = do { binds_w_locs <- rep_binds' binds
 872                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 873
 874 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 875 rep_binds' binds = mapM rep_bind (bagToList binds)
 876
 877 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 878 -- Assumes: all the binders of the binding are alrady in the meta-env
 879
 880 -- Note GHC treats declarations of a variable (not a pattern)
 881 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 882 -- with an empty list of patterns
 883 rep_bind (L loc (FunBind { fun_id = fn,
 884                            fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
 885  = do { (ss,wherecore) <- repBinds wheres
 886         ; guardcore <- addBinds ss (repGuards guards)
 887         ; fn'  <- lookupLBinder fn
 888         ; p    <- repPvar fn'
 889         ; ans  <- repVal p guardcore wherecore
 890         ; ans' <- wrapGenSyns ss ans
 891         ; return (loc, ans') }
 892
 893 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 894  =   do { ms1 <- mapM repClauseTup ms
 895         ; fn' <- lookupLBinder fn
 896         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 897         ; return (loc, ans) }
 898
 899 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 900  =   do { patcore <- repLP pat
 901         ; (ss,wherecore) <- repBinds wheres
 902         ; guardcore <- addBinds ss (repGuards guards)
 903         ; ans  <- repVal patcore guardcore wherecore
 904         ; ans' <- wrapGenSyns ss ans
 905         ; return (loc, ans') }
 906
 907 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
 908  =   do { v' <- lookupBinder v
 909         ; e2 <- repLE e
 910         ; x <- repNormal e2
 911         ; patcore <- repPvar v'
 912         ; empty_decls <- coreList decQTyConName []
 913         ; ans <- repVal patcore x empty_decls
 914         ; return (srcLocSpan (getSrcLoc v), ans) }
 915
 916 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
 917
 918 -----------------------------------------------------------------------------
 919 -- Since everything in a Bind is mutually recursive we need rename all
 920 -- all the variables simultaneously. For example:
 921 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 922 -- do { f'1 <- gensym "f"
 923 --    ; g'2 <- gensym "g"
 924 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 925 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 926 --      ]}
 927 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 928 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 929 -- together. As we do this we collect GenSymBinds's which represent the renamed
 930 -- variables bound by the Bindings. In order not to lose track of these
 931 -- representations we build a shadow datatype MB with the same structure as
 932 -- MonoBinds, but which has slots for the representations
 933
 934
 935 -----------------------------------------------------------------------------
 936 -- GHC allows a more general form of lambda abstraction than specified
 937 -- by Haskell 98. In particular it allows guarded lambda's like :
 938 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 939 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 940 -- (\ p1 .. pn -> exp) by causing an error.
 941
 942 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
 943 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 944  = do { let bndrs = collectPatsBinders ps ;
 945       ; ss  <- mkGenSyms bndrs
 946       ; lam <- addBinds ss (
 947                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 948       ; wrapGenSyns ss lam }
 949
 950 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
 951
 952
 953 -----------------------------------------------------------------------------
 954 --                      Patterns
 955 -- repP deals with patterns.  It assumes that we have already
 956 -- walked over the pattern(s) once to collect the binders, and
 957 -- have extended the environment.  So every pattern-bound
 958 -- variable should already appear in the environment.
 959
 960 -- Process a list of patterns
 961 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
 962 repLPs ps = do { ps' <- mapM repLP ps ;
 963                  coreList patQTyConName ps' }
 964
 965 repLP :: LPat Name -> DsM (Core TH.PatQ)
 966 repLP (L _ p) = repP p
 967
 968 repP :: Pat Name -> DsM (Core TH.PatQ)
 969 repP (WildPat _)       = repPwild
 970 repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
 971 repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
 972 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
 973 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
 974 repP (ParPat p)        = repLP p
 975 repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
 976 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 977 repP (ConPatIn dc details)
 978  = do { con_str <- lookupLOcc dc
 979       ; case details of
 980          PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
 981          RecCon rec   -> do { let flds = rec_flds rec
 982                             ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
 983                             ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
 984                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
 985                             ; fps' <- coreList fieldPatQTyConName fps
 986                             ; repPrec con_str fps' }
 987          InfixCon p1 p2 -> do { p1' <- repLP p1;
 988                                 p2' <- repLP p2;
 989                                 repPinfix p1' con_str p2' }
 990    }
 991 repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
 992 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 993 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
 994         -- The problem is to do with scoped type variables.
 995         -- To implement them, we have to implement the scoping rules
 996         -- here in DsMeta, and I don't want to do that today!
 997         --       do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 998         --      repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
 999         --      repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1000
1001 repP other = notHandled "Exotic pattern" (ppr other)
1002
1003 ----------------------------------------------------------
1004 -- Declaration ordering helpers
1005
1006 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1007 sort_by_loc xs = sortBy comp xs
1008     where comp x y = compare (fst x) (fst y)
1009
1010 de_loc :: [(a, b)] -> [b]
1011 de_loc = map snd
1012
1013 ----------------------------------------------------------
1014 --      The meta-environment
1015
1016 -- A name/identifier association for fresh names of locally bound entities
1017 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
1018                                 -- I.e.         (x, x_id) means
1019                                 --      let x_id = gensym "x" in ...
1020
1021 -- Generate a fresh name for a locally bound entity
1022
1023 mkGenSyms :: [Name] -> DsM [GenSymBind]
1024 -- We can use the existing name.  For example:
1025 --      [| \x_77 -> x_77 + x_77 |]
1026 -- desugars to
1027 --      do { x_77 <- genSym "x"; .... }
1028 -- We use the same x_77 in the desugared program, but with the type Bndr
1029 -- instead of Int
1030 --
1031 -- We do make it an Internal name, though (hence localiseName)
1032 --
1033 -- Nevertheless, it's monadic because we have to generate nameTy
1034 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1035                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1036
1037
1038 addBinds :: [GenSymBind] -> DsM a -> DsM a
1039 -- Add a list of fresh names for locally bound entities to the
1040 -- meta environment (which is part of the state carried around
1041 -- by the desugarer monad)
1042 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1043
1044 -- Look up a locally bound name
1045 --
1046 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1047 lookupLBinder (L _ n) = lookupBinder n
1048
1049 lookupBinder :: Name -> DsM (Core TH.Name)
1050 lookupBinder n
1051   = do { mb_val <- dsLookupMetaEnv n;
1052          case mb_val of
1053             Just (Bound x) -> return (coreVar x)
1054             _              -> failWithDs msg }
1055   where
1056     msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1057
1058 -- Look up a name that is either locally bound or a global name
1059 --
1060 --  * If it is a global name, generate the "original name" representation (ie,
1061 --   the <module>:<name> form) for the associated entity
1062 --
1063 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1064 -- Lookup an occurrence; it can't be a splice.
1065 -- Use the in-scope bindings if they exist
1066 lookupLOcc (L _ n) = lookupOcc n
1067
1068 lookupOcc :: Name -> DsM (Core TH.Name)
1069 lookupOcc n
1070   = do {  mb_val <- dsLookupMetaEnv n ;
1071           case mb_val of
1072                 Nothing         -> globalVar n
1073                 Just (Bound x)  -> return (coreVar x)
1074                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1075     }
1076
1077 lookupTvOcc :: Name -> DsM (Core TH.Name)
1078 -- Type variables can't be staged and are not lexically scoped in TH
1079 lookupTvOcc n
1080   = do {  mb_val <- dsLookupMetaEnv n ;
1081           case mb_val of
1082                 Just (Bound x)  -> return (coreVar x)
1083                 _               -> failWithDs msg
1084     }
1085   where
1086     msg = vcat  [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1087                 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1088
1089 globalVar :: Name -> DsM (Core TH.Name)
1090 -- Not bound by the meta-env
1091 -- Could be top-level; or could be local
1092 --      f x = $(g [| x |])
1093 -- Here the x will be local
1094 globalVar name
1095   | isExternalName name
1096   = do  { MkC mod <- coreStringLit name_mod
1097         ; MkC pkg <- coreStringLit name_pkg
1098         ; MkC occ <- occNameLit name
1099         ; rep2 mk_varg [pkg,mod,occ] }
1100   | otherwise
1101   = do  { MkC occ <- occNameLit name
1102         ; MkC uni <- coreIntLit (getKey (getUnique name))
1103         ; rep2 mkNameLName [occ,uni] }
1104   where
1105       mod = ASSERT( isExternalName name) nameModule name
1106       name_mod = moduleNameString (moduleName mod)
1107       name_pkg = packageIdString (modulePackageId mod)
1108       name_occ = nameOccName name
1109       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1110               | OccName.isVarOcc  name_occ = mkNameG_vName
1111               | OccName.isTcOcc   name_occ = mkNameG_tcName
1112               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
1113
1114 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
1115            -> DsM Type  -- The type
1116 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1117                           return (mkTyConApp tc []) }
1118
1119 wrapGenSyns :: [GenSymBind]
1120             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1121 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
1122 --      --> bindQ (gensym nm1) (\ id1 ->
1123 --          bindQ (gensym nm2 (\ id2 ->
1124 --          y))
1125
1126 wrapGenSyns binds body@(MkC b)
1127   = do  { var_ty <- lookupType nameTyConName
1128         ; go var_ty binds }
1129   where
1130     [elt_ty] = tcTyConAppArgs (exprType b)
1131         -- b :: Q a, so we can get the type 'a' by looking at the
1132         -- argument type. NB: this relies on Q being a data/newtype,
1133         -- not a type synonym
1134
1135     go _ [] = return body
1136     go var_ty ((name,id) : binds)
1137       = do { MkC body'  <- go var_ty binds
1138            ; lit_str    <- occNameLit name
1139            ; gensym_app <- repGensym lit_str
1140            ; repBindQ var_ty elt_ty
1141                       gensym_app (MkC (Lam id body')) }
1142
1143 -- Just like wrapGenSym, but don't actually do the gensym
1144 -- Instead use the existing name:
1145 --      let x = "x" in ...
1146 -- Only used for [Decl], and for the class ops in class
1147 -- and instance decls
1148 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1149 wrapNongenSyms binds (MkC body)
1150   = do { binds' <- mapM do_one binds ;
1151          return (MkC (mkLets binds' body)) }
1152   where
1153     do_one (name,id)
1154         = do { MkC lit_str <- occNameLit name
1155              ; MkC var <- rep2 mkNameName [lit_str]
1156              ; return (NonRec id var) }
1157
1158 occNameLit :: Name -> DsM (Core String)
1159 occNameLit n = coreStringLit (occNameString (nameOccName n))
1160
1161
1162 -- %*********************************************************************
1163 -- %*                                                                   *
1164 --              Constructing code
1165 -- %*                                                                   *
1166 -- %*********************************************************************
1167
1168 -----------------------------------------------------------------------------
1169 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1170 -- we invent a new datatype which uses phantom types.
1171
1172 newtype Core a = MkC CoreExpr
1173 unC :: Core a -> CoreExpr
1174 unC (MkC x) = x
1175
1176 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1177 rep2 n xs = do { id <- dsLookupGlobalId n
1178                ; return (MkC (foldl App (Var id) xs)) }
1179
1180 -- Then we make "repConstructors" which use the phantom types for each of the
1181 -- smart constructors of the Meta.Meta datatypes.
1182
1183
1184 -- %*********************************************************************
1185 -- %*                                                                   *
1186 --              The 'smart constructors'
1187 -- %*                                                                   *
1188 -- %*********************************************************************
1189
1190 --------------- Patterns -----------------
1191 repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
1192 repPlit (MkC l) = rep2 litPName [l]
1193
1194 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1195 repPvar (MkC s) = rep2 varPName [s]
1196
1197 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1198 repPtup (MkC ps) = rep2 tupPName [ps]
1199
1200 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1201 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1202
1203 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1204 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1205
1206 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1207 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1208
1209 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1210 repPtilde (MkC p) = rep2 tildePName [p]
1211
1212 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1213 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1214
1215 repPwild  :: DsM (Core TH.PatQ)
1216 repPwild = rep2 wildPName []
1217
1218 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1219 repPlist (MkC ps) = rep2 listPName [ps]
1220
1221 --------------- Expressions -----------------
1222 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1223 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1224                    | otherwise                  = repVar str
1225
1226 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1227 repVar (MkC s) = rep2 varEName [s]
1228
1229 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1230 repCon (MkC s) = rep2 conEName [s]
1231
1232 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1233 repLit (MkC c) = rep2 litEName [c]
1234
1235 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1236 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1237
1238 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1239 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1240
1241 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1242 repTup (MkC es) = rep2 tupEName [es]
1243
1244 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1245 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
1246
1247 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1248 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1249
1250 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1251 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1252
1253 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1254 repDoE (MkC ss) = rep2 doEName [ss]
1255
1256 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1257 repComp (MkC ss) = rep2 compEName [ss]
1258
1259 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1260 repListExp (MkC es) = rep2 listEName [es]
1261
1262 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1263 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1264
1265 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1266 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1267
1268 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1269 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1270
1271 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1272 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1273
1274 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1275 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1276
1277 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1278 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1279
1280 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1281 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1282
1283 ------------ Right hand sides (guarded expressions) ----
1284 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1285 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1286
1287 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1288 repNormal (MkC e) = rep2 normalBName [e]
1289
1290 ------------ Guards ----
1291 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1292 repLNormalGE g e = do g' <- repLE g
1293                       e' <- repLE e
1294                       repNormalGE g' e'
1295
1296 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1297 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1298
1299 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1300 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1301
1302 ------------- Stmts -------------------
1303 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1304 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1305
1306 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1307 repLetSt (MkC ds) = rep2 letSName [ds]
1308
1309 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1310 repNoBindSt (MkC e) = rep2 noBindSName [e]
1311
1312 -------------- Range (Arithmetic sequences) -----------
1313 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1314 repFrom (MkC x) = rep2 fromEName [x]
1315
1316 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1317 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1318
1319 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1320 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1321
1322 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1323 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1324
1325 ------------ Match and Clause Tuples -----------
1326 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1327 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1328
1329 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1330 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1331
1332 -------------- Dec -----------------------------
1333 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1334 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1335
1336 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1337 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1338
1339 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name]
1340         -> Maybe (Core [TH.TypeQ])
1341         -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1342 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1343   = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1344 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1345   = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1346
1347 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name]
1348            -> Maybe (Core [TH.TypeQ])
1349            -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1350 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1351   = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1352 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1353   = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1354
1355 repTySyn :: Core TH.Name -> Core [TH.Name]
1356          -> Maybe (Core [TH.TypeQ])
1357          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1358 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1359   = rep2 tySynDName [nm, tvs, rhs]
1360 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1361   = rep2 tySynInstDName [nm, tys, rhs]
1362
1363 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1364 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1365
1366 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name]
1367          -> Core [TH.FunDep] -> Core [TH.DecQ]
1368          -> DsM (Core TH.DecQ)
1369 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1370   = rep2 classDName [cxt, cls, tvs, fds, ds]
1371
1372 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1373 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1374
1375 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1376 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1377
1378 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1379                -> DsM (Core TH.DecQ)
1380 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1381   = rep2 pragSpecInlDName [nm, ty, ispec]
1382
1383 repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name]
1384           -> DsM (Core TH.DecQ)
1385 repFamily (MkC flav) (MkC nm) (MkC tvs)
1386     = rep2 familyDName [flav, nm, tvs]
1387
1388 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1389 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1390   = rep2 inlineSpecNoPhaseName [inline, conlike]
1391
1392 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1393                    -> DsM (Core TH.InlineSpecQ)
1394 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1395   = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1396
1397 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1398 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1399
1400 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1401 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1402
1403 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1404 repCtxt (MkC tys) = rep2 cxtName [tys]
1405
1406 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1407 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1408
1409 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1410 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1411
1412 repConstr :: Core TH.Name -> HsConDeclDetails Name
1413           -> DsM (Core TH.ConQ)
1414 repConstr con (PrefixCon ps)
1415     = do arg_tys  <- mapM repBangTy ps
1416          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1417          rep2 normalCName [unC con, unC arg_tys1]
1418 repConstr con (RecCon ips)
1419     = do arg_vs   <- mapM lookupLOcc (map cd_fld_name ips)
1420          arg_tys  <- mapM repBangTy (map cd_fld_type ips)
1421          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1422                               arg_vs arg_tys
1423          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1424          rep2 recCName [unC con, unC arg_vtys']
1425 repConstr con (InfixCon st1 st2)
1426     = do arg1 <- repBangTy st1
1427          arg2 <- repBangTy st2
1428          rep2 infixCName [unC arg1, unC con, unC arg2]
1429
1430 ------------ Types -------------------
1431
1432 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1433 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1434     = rep2 forallTName [tvars, ctxt, ty]
1435
1436 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1437 repTvar (MkC s) = rep2 varTName [s]
1438
1439 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1440 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1441
1442 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1443 repTapps f []     = return f
1444 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1445
1446 --------- Type constructors --------------
1447
1448 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1449 repNamedTyCon (MkC s) = rep2 conTName [s]
1450
1451 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1452 -- Note: not Core Int; it's easier to be direct here
1453 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1454
1455 repArrowTyCon :: DsM (Core TH.TypeQ)
1456 repArrowTyCon = rep2 arrowTName []
1457
1458 repListTyCon :: DsM (Core TH.TypeQ)
1459 repListTyCon = rep2 listTName []
1460
1461
1462 ----------------------------------------------------------
1463 --              Literals
1464
1465 repLiteral :: HsLit -> DsM (Core TH.Lit)
1466 repLiteral lit
1467   = do lit' <- case lit of
1468                    HsIntPrim i    -> mk_integer i
1469                    HsWordPrim w   -> mk_integer w
1470                    HsInt i        -> mk_integer i
1471                    HsFloatPrim r  -> mk_rational r
1472                    HsDoublePrim r -> mk_rational r
1473                    _ -> return lit
1474        lit_expr <- dsLit lit'
1475        case mb_lit_name of
1476           Just lit_name -> rep2 lit_name [lit_expr]
1477           Nothing -> notHandled "Exotic literal" (ppr lit)
1478   where
1479     mb_lit_name = case lit of
1480                  HsInteger _ _  -> Just integerLName
1481                  HsInt     _    -> Just integerLName
1482                  HsIntPrim _    -> Just intPrimLName
1483                  HsWordPrim _   -> Just wordPrimLName
1484                  HsFloatPrim _  -> Just floatPrimLName
1485                  HsDoublePrim _ -> Just doublePrimLName
1486                  HsChar _       -> Just charLName
1487                  HsString _     -> Just stringLName
1488                  HsRat _ _      -> Just rationalLName
1489                  _              -> Nothing
1490
1491 mk_integer :: Integer -> DsM HsLit
1492 mk_integer  i = do integer_ty <- lookupType integerTyConName
1493                    return $ HsInteger i integer_ty
1494 mk_rational :: Rational -> DsM HsLit
1495 mk_rational r = do rat_ty <- lookupType rationalTyConName
1496                    return $ HsRat r rat_ty
1497 mk_string :: FastString -> DsM HsLit
1498 mk_string s = return $ HsString s
1499
1500 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1501 repOverloadedLiteral (OverLit { ol_val = val})
1502   = do { lit <- mk_lit val; repLiteral lit }
1503         -- The type Rational will be in the environment, becuase
1504         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1505         -- and rationalL is sucked in when any TH stuff is used
1506
1507 mk_lit :: OverLitVal -> DsM HsLit
1508 mk_lit (HsIntegral i)   = mk_integer  i
1509 mk_lit (HsFractional f) = mk_rational f
1510 mk_lit (HsIsString s)   = mk_string   s
1511
1512 --------------- Miscellaneous -------------------
1513
1514 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1515 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1516
1517 repBindQ :: Type -> Type        -- a and b
1518          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1519 repBindQ ty_a ty_b (MkC x) (MkC y)
1520   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1521
1522 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1523 repSequenceQ ty_a (MkC list)
1524   = rep2 sequenceQName [Type ty_a, list]
1525
1526 ------------ Lists and Tuples -------------------
1527 -- turn a list of patterns into a single pattern matching a list
1528
1529 coreList :: Name        -- Of the TyCon of the element type
1530          -> [Core a] -> DsM (Core [a])
1531 coreList tc_name es
1532   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1533
1534 coreList' :: Type       -- The element type
1535           -> [Core a] -> Core [a]
1536 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1537
1538 nonEmptyCoreList :: [Core a] -> Core [a]
1539   -- The list must be non-empty so we can get the element type
1540   -- Otherwise use coreList
1541 nonEmptyCoreList []           = panic "coreList: empty argument"
1542 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1543
1544 coreStringLit :: String -> DsM (Core String)
1545 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1546
1547 ------------ Bool, Literals & Variables -------------------
1548
1549 coreBool :: Bool -> Core Bool
1550 coreBool False = MkC $ mkConApp falseDataCon []
1551 coreBool True  = MkC $ mkConApp trueDataCon  []
1552
1553 coreIntLit :: Int -> DsM (Core Int)
1554 coreIntLit i = return (MkC (mkIntExprInt i))
1555
1556 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1557 coreVar id = MkC (Var id)
1558
1559 ----------------- Failure -----------------------
1560 notHandled :: String -> SDoc -> DsM a
1561 notHandled what doc = failWithDs msg
1562   where
1563     msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1564              2 doc
1565
1566
1567 -- %************************************************************************
1568 -- %*                                                                   *
1569 --              The known-key names for Template Haskell
1570 -- %*                                                                   *
1571 -- %************************************************************************
1572
1573 -- To add a name, do three things
1574 --
1575 --  1) Allocate a key
1576 --  2) Make a "Name"
1577 --  3) Add the name to knownKeyNames
1578
1579 templateHaskellNames :: [Name]
1580 -- The names that are implicitly mentioned by ``bracket''
1581 -- Should stay in sync with the import list of DsMeta
1582
1583 templateHaskellNames = [
1584     returnQName, bindQName, sequenceQName, newNameName, liftName,
1585     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1586
1587     -- Lit
1588     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1589     floatPrimLName, doublePrimLName, rationalLName,
1590     -- Pat
1591     litPName, varPName, tupPName, conPName, tildePName, infixPName,
1592     asPName, wildPName, recPName, listPName, sigPName,
1593     -- FieldPat
1594     fieldPatName,
1595     -- Match
1596     matchName,
1597     -- Clause
1598     clauseName,
1599     -- Exp
1600     varEName, conEName, litEName, appEName, infixEName,
1601     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1602     condEName, letEName, caseEName, doEName, compEName,
1603     fromEName, fromThenEName, fromToEName, fromThenToEName,
1604     listEName, sigEName, recConEName, recUpdEName,
1605     -- FieldExp
1606     fieldExpName,
1607     -- Body
1608     guardedBName, normalBName,
1609     -- Guard
1610     normalGEName, patGEName,
1611     -- Stmt
1612     bindSName, letSName, noBindSName, parSName,
1613     -- Dec
1614     funDName, valDName, dataDName, newtypeDName, tySynDName,
1615     classDName, instanceDName, sigDName, forImpDName,
1616     pragInlDName, pragSpecDName, pragSpecInlDName,
1617     familyDName, dataInstDName, newtypeInstDName, tySynInstDName,
1618     -- Cxt
1619     cxtName,
1620     -- Pred
1621     classPName, equalPName,
1622     -- Strict
1623     isStrictName, notStrictName,
1624     -- Con
1625     normalCName, recCName, infixCName, forallCName,
1626     -- StrictType
1627     strictTypeName,
1628     -- VarStrictType
1629     varStrictTypeName,
1630     -- Type
1631     forallTName, varTName, conTName, appTName,
1632     tupleTName, arrowTName, listTName,
1633     -- Callconv
1634     cCallName, stdCallName,
1635     -- Safety
1636     unsafeName,
1637     safeName,
1638     threadsafeName,
1639     -- InlineSpec
1640     inlineSpecNoPhaseName, inlineSpecPhaseName,
1641     -- FunDep
1642     funDepName,
1643     -- FamFlavour
1644     typeFamName, dataFamName,
1645
1646     -- And the tycons
1647     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1648     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1649     stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1650     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1651     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1652     fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName,
1653
1654     -- Quasiquoting
1655     quoteExpName, quotePatName]
1656
1657 thSyn, thLib, qqLib :: Module
1658 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1659 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1660 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1661
1662 mkTHModule :: FastString -> Module
1663 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1664
1665 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1666 libFun = mk_known_key_name OccName.varName thLib
1667 libTc  = mk_known_key_name OccName.tcName  thLib
1668 thFun  = mk_known_key_name OccName.varName thSyn
1669 thTc   = mk_known_key_name OccName.tcName  thSyn
1670 qqFun  = mk_known_key_name OccName.varName qqLib
1671
1672 -------------------- TH.Syntax -----------------------
1673 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1674     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1675     matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name
1676 qTyConName        = thTc (fsLit "Q")            qTyConKey
1677 nameTyConName     = thTc (fsLit "Name")         nameTyConKey
1678 fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey
1679 patTyConName      = thTc (fsLit "Pat")          patTyConKey
1680 fieldPatTyConName = thTc (fsLit "FieldPat")     fieldPatTyConKey
1681 expTyConName      = thTc (fsLit "Exp")          expTyConKey
1682 decTyConName      = thTc (fsLit "Dec")          decTyConKey
1683 typeTyConName     = thTc (fsLit "Type")         typeTyConKey
1684 matchTyConName    = thTc (fsLit "Match")        matchTyConKey
1685 clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey
1686 funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey
1687 predTyConName     = thTc (fsLit "Pred")         predTyConKey
1688
1689 returnQName, bindQName, sequenceQName, newNameName, liftName,
1690     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1691     mkNameLName :: Name
1692 returnQName   = thFun (fsLit "returnQ")   returnQIdKey
1693 bindQName     = thFun (fsLit "bindQ")     bindQIdKey
1694 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1695 newNameName    = thFun (fsLit "newName")   newNameIdKey
1696 liftName      = thFun (fsLit "lift")      liftIdKey
1697 mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
1698 mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
1699 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
1700 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1701 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
1702
1703
1704 -------------------- TH.Lib -----------------------
1705 -- data Lit = ...
1706 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1707     floatPrimLName, doublePrimLName, rationalLName :: Name
1708 charLName       = libFun (fsLit "charL")       charLIdKey
1709 stringLName     = libFun (fsLit "stringL")     stringLIdKey
1710 integerLName    = libFun (fsLit "integerL")    integerLIdKey
1711 intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
1712 wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
1713 floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
1714 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1715 rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
1716
1717 -- data Pat = ...
1718 litPName, varPName, tupPName, conPName, infixPName, tildePName,
1719     asPName, wildPName, recPName, listPName, sigPName :: Name
1720 litPName   = libFun (fsLit "litP")   litPIdKey
1721 varPName   = libFun (fsLit "varP")   varPIdKey
1722 tupPName   = libFun (fsLit "tupP")   tupPIdKey
1723 conPName   = libFun (fsLit "conP")   conPIdKey
1724 infixPName = libFun (fsLit "infixP") infixPIdKey
1725 tildePName = libFun (fsLit "tildeP") tildePIdKey
1726 asPName    = libFun (fsLit "asP")    asPIdKey
1727 wildPName  = libFun (fsLit "wildP")  wildPIdKey
1728 recPName   = libFun (fsLit "recP")   recPIdKey
1729 listPName  = libFun (fsLit "listP")  listPIdKey
1730 sigPName   = libFun (fsLit "sigP")   sigPIdKey
1731
1732 -- type FieldPat = ...
1733 fieldPatName :: Name
1734 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1735
1736 -- data Match = ...
1737 matchName :: Name
1738 matchName = libFun (fsLit "match") matchIdKey
1739
1740 -- data Clause = ...
1741 clauseName :: Name
1742 clauseName = libFun (fsLit "clause") clauseIdKey
1743
1744 -- data Exp = ...
1745 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1746     sectionLName, sectionRName, lamEName, tupEName, condEName,
1747     letEName, caseEName, doEName, compEName :: Name
1748 varEName        = libFun (fsLit "varE")        varEIdKey
1749 conEName        = libFun (fsLit "conE")        conEIdKey
1750 litEName        = libFun (fsLit "litE")        litEIdKey
1751 appEName        = libFun (fsLit "appE")        appEIdKey
1752 infixEName      = libFun (fsLit "infixE")      infixEIdKey
1753 infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
1754 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
1755 sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
1756 lamEName        = libFun (fsLit "lamE")        lamEIdKey
1757 tupEName        = libFun (fsLit "tupE")        tupEIdKey
1758 condEName       = libFun (fsLit "condE")       condEIdKey
1759 letEName        = libFun (fsLit "letE")        letEIdKey
1760 caseEName       = libFun (fsLit "caseE")       caseEIdKey
1761 doEName         = libFun (fsLit "doE")         doEIdKey
1762 compEName       = libFun (fsLit "compE")       compEIdKey
1763 -- ArithSeq skips a level
1764 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1765 fromEName       = libFun (fsLit "fromE")       fromEIdKey
1766 fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey
1767 fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey
1768 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1769 -- end ArithSeq
1770 listEName, sigEName, recConEName, recUpdEName :: Name
1771 listEName       = libFun (fsLit "listE")       listEIdKey
1772 sigEName        = libFun (fsLit "sigE")        sigEIdKey
1773 recConEName     = libFun (fsLit "recConE")     recConEIdKey
1774 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
1775
1776 -- type FieldExp = ...
1777 fieldExpName :: Name
1778 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1779
1780 -- data Body = ...
1781 guardedBName, normalBName :: Name
1782 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1783 normalBName  = libFun (fsLit "normalB")  normalBIdKey
1784
1785 -- data Guard = ...
1786 normalGEName, patGEName :: Name
1787 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1788 patGEName    = libFun (fsLit "patGE")    patGEIdKey
1789
1790 -- data Stmt = ...
1791 bindSName, letSName, noBindSName, parSName :: Name
1792 bindSName   = libFun (fsLit "bindS")   bindSIdKey
1793 letSName    = libFun (fsLit "letS")    letSIdKey
1794 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1795 parSName    = libFun (fsLit "parS")    parSIdKey
1796
1797 -- data Dec = ...
1798 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1799     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1800     pragSpecInlDName, familyDName, dataInstDName, newtypeInstDName,
1801     tySynInstDName :: Name
1802 funDName         = libFun (fsLit "funD")         funDIdKey
1803 valDName         = libFun (fsLit "valD")         valDIdKey
1804 dataDName        = libFun (fsLit "dataD")        dataDIdKey
1805 newtypeDName     = libFun (fsLit "newtypeD")     newtypeDIdKey
1806 tySynDName       = libFun (fsLit "tySynD")       tySynDIdKey
1807 classDName       = libFun (fsLit "classD")       classDIdKey
1808 instanceDName    = libFun (fsLit "instanceD")    instanceDIdKey
1809 sigDName         = libFun (fsLit "sigD")         sigDIdKey
1810 forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
1811 pragInlDName     = libFun (fsLit "pragInlD")     pragInlDIdKey
1812 pragSpecDName    = libFun (fsLit "pragSpecD")    pragSpecDIdKey
1813 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1814 familyDName      = libFun (fsLit "familyD")      familyDIdKey
1815 dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
1816 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1817 tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
1818
1819 -- type Ctxt = ...
1820 cxtName :: Name
1821 cxtName = libFun (fsLit "cxt") cxtIdKey
1822
1823 -- data Pred = ...
1824 classPName, equalPName :: Name
1825 classPName = libFun (fsLit "classP") classPIdKey
1826 equalPName = libFun (fsLit "equalP") equalPIdKey
1827
1828 -- data Strict = ...
1829 isStrictName, notStrictName :: Name
1830 isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
1831 notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
1832
1833 -- data Con = ...
1834 normalCName, recCName, infixCName, forallCName :: Name
1835 normalCName = libFun (fsLit "normalC") normalCIdKey
1836 recCName    = libFun (fsLit "recC")    recCIdKey
1837 infixCName  = libFun (fsLit "infixC")  infixCIdKey
1838 forallCName  = libFun (fsLit "forallC")  forallCIdKey
1839
1840 -- type StrictType = ...
1841 strictTypeName :: Name
1842 strictTypeName    = libFun  (fsLit "strictType")    strictTKey
1843
1844 -- type VarStrictType = ...
1845 varStrictTypeName :: Name
1846 varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
1847
1848 -- data Type = ...
1849 forallTName, varTName, conTName, tupleTName, arrowTName,
1850     listTName, appTName :: Name
1851 forallTName = libFun (fsLit "forallT") forallTIdKey
1852 varTName    = libFun (fsLit "varT")    varTIdKey
1853 conTName    = libFun (fsLit "conT")    conTIdKey
1854 tupleTName  = libFun (fsLit "tupleT") tupleTIdKey
1855 arrowTName  = libFun (fsLit "arrowT") arrowTIdKey
1856 listTName   = libFun (fsLit "listT")  listTIdKey
1857 appTName    = libFun (fsLit "appT")    appTIdKey
1858
1859 -- data Callconv = ...
1860 cCallName, stdCallName :: Name
1861 cCallName = libFun (fsLit "cCall") cCallIdKey
1862 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1863
1864 -- data Safety = ...
1865 unsafeName, safeName, threadsafeName :: Name
1866 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
1867 safeName       = libFun (fsLit "safe") safeIdKey
1868 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1869
1870 -- data InlineSpec = ...
1871 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1872 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1873 inlineSpecPhaseName   = libFun (fsLit "inlineSpecPhase")   inlineSpecPhaseIdKey
1874
1875 -- data FunDep = ...
1876 funDepName :: Name
1877 funDepName     = libFun (fsLit "funDep") funDepIdKey
1878
1879 -- data FamFlavour = ...
1880 typeFamName, dataFamName :: Name
1881 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1882 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1883
1884 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1885     decQTyConName, conQTyConName, strictTypeQTyConName,
1886     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1887     patQTyConName, fieldPatQTyConName, predQTyConName :: Name
1888 matchQTyConName         = libTc (fsLit "MatchQ")        matchQTyConKey
1889 clauseQTyConName        = libTc (fsLit "ClauseQ")       clauseQTyConKey
1890 expQTyConName           = libTc (fsLit "ExpQ")          expQTyConKey
1891 stmtQTyConName          = libTc (fsLit "StmtQ")         stmtQTyConKey
1892 decQTyConName           = libTc (fsLit "DecQ")          decQTyConKey
1893 conQTyConName           = libTc (fsLit "ConQ")          conQTyConKey
1894 strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
1895 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1896 typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
1897 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
1898 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
1899 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
1900 predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
1901
1902 -- quasiquoting
1903 quoteExpName, quotePatName :: Name
1904 quoteExpName        = qqFun (fsLit "quoteExp") quoteExpKey
1905 quotePatName        = qqFun (fsLit "quotePat") quotePatKey
1906
1907 -- TyConUniques available: 100-129
1908 -- Check in PrelNames if you want to change this
1909
1910 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
1911     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
1912     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
1913     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
1914     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
1915     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
1916     predQTyConKey :: Unique
1917 expTyConKey             = mkPreludeTyConUnique 100
1918 matchTyConKey           = mkPreludeTyConUnique 101
1919 clauseTyConKey          = mkPreludeTyConUnique 102
1920 qTyConKey               = mkPreludeTyConUnique 103
1921 expQTyConKey            = mkPreludeTyConUnique 104
1922 decQTyConKey            = mkPreludeTyConUnique 105
1923 patTyConKey             = mkPreludeTyConUnique 106
1924 matchQTyConKey          = mkPreludeTyConUnique 107
1925 clauseQTyConKey         = mkPreludeTyConUnique 108
1926 stmtQTyConKey           = mkPreludeTyConUnique 109
1927 conQTyConKey            = mkPreludeTyConUnique 110
1928 typeQTyConKey           = mkPreludeTyConUnique 111
1929 typeTyConKey            = mkPreludeTyConUnique 112
1930 decTyConKey             = mkPreludeTyConUnique 113
1931 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
1932 strictTypeQTyConKey     = mkPreludeTyConUnique 115
1933 fieldExpTyConKey        = mkPreludeTyConUnique 116
1934 fieldPatTyConKey        = mkPreludeTyConUnique 117
1935 nameTyConKey            = mkPreludeTyConUnique 118
1936 patQTyConKey            = mkPreludeTyConUnique 119
1937 fieldPatQTyConKey       = mkPreludeTyConUnique 120
1938 fieldExpQTyConKey       = mkPreludeTyConUnique 121
1939 funDepTyConKey          = mkPreludeTyConUnique 122
1940 predTyConKey            = mkPreludeTyConUnique 123
1941 predQTyConKey           = mkPreludeTyConUnique 124
1942
1943 -- IdUniques available: 200-399
1944 -- If you want to change this, make sure you check in PrelNames
1945
1946 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
1947     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
1948     mkNameLIdKey :: Unique
1949 returnQIdKey        = mkPreludeMiscIdUnique 200
1950 bindQIdKey          = mkPreludeMiscIdUnique 201
1951 sequenceQIdKey      = mkPreludeMiscIdUnique 202
1952 liftIdKey           = mkPreludeMiscIdUnique 203
1953 newNameIdKey         = mkPreludeMiscIdUnique 204
1954 mkNameIdKey          = mkPreludeMiscIdUnique 205
1955 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
1956 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
1957 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
1958 mkNameLIdKey         = mkPreludeMiscIdUnique 209
1959
1960
1961 -- data Lit = ...
1962 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
1963     floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
1964 charLIdKey        = mkPreludeMiscIdUnique 210
1965 stringLIdKey      = mkPreludeMiscIdUnique 211
1966 integerLIdKey     = mkPreludeMiscIdUnique 212
1967 intPrimLIdKey     = mkPreludeMiscIdUnique 213
1968 wordPrimLIdKey    = mkPreludeMiscIdUnique 214
1969 floatPrimLIdKey   = mkPreludeMiscIdUnique 215
1970 doublePrimLIdKey  = mkPreludeMiscIdUnique 216
1971 rationalLIdKey    = mkPreludeMiscIdUnique 217
1972
1973 -- data Pat = ...
1974 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey,
1975     asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
1976 litPIdKey         = mkPreludeMiscIdUnique 220
1977 varPIdKey         = mkPreludeMiscIdUnique 221
1978 tupPIdKey         = mkPreludeMiscIdUnique 222
1979 conPIdKey         = mkPreludeMiscIdUnique 223
1980 infixPIdKey       = mkPreludeMiscIdUnique 312
1981 tildePIdKey       = mkPreludeMiscIdUnique 224
1982 asPIdKey          = mkPreludeMiscIdUnique 225
1983 wildPIdKey        = mkPreludeMiscIdUnique 226
1984 recPIdKey         = mkPreludeMiscIdUnique 227
1985 listPIdKey        = mkPreludeMiscIdUnique 228
1986 sigPIdKey         = mkPreludeMiscIdUnique 229
1987
1988 -- type FieldPat = ...
1989 fieldPatIdKey :: Unique
1990 fieldPatIdKey       = mkPreludeMiscIdUnique 230
1991
1992 -- data Match = ...
1993 matchIdKey :: Unique
1994 matchIdKey          = mkPreludeMiscIdUnique 231
1995
1996 -- data Clause = ...
1997 clauseIdKey :: Unique
1998 clauseIdKey         = mkPreludeMiscIdUnique 232
1999
2000 -- data Exp = ...
2001 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2002     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2003     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2004     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2005     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2006 varEIdKey         = mkPreludeMiscIdUnique 240
2007 conEIdKey         = mkPreludeMiscIdUnique 241
2008 litEIdKey         = mkPreludeMiscIdUnique 242
2009 appEIdKey         = mkPreludeMiscIdUnique 243
2010 infixEIdKey       = mkPreludeMiscIdUnique 244
2011 infixAppIdKey     = mkPreludeMiscIdUnique 245
2012 sectionLIdKey     = mkPreludeMiscIdUnique 246
2013 sectionRIdKey     = mkPreludeMiscIdUnique 247
2014 lamEIdKey         = mkPreludeMiscIdUnique 248
2015 tupEIdKey         = mkPreludeMiscIdUnique 249
2016 condEIdKey        = mkPreludeMiscIdUnique 250
2017 letEIdKey         = mkPreludeMiscIdUnique 251
2018 caseEIdKey        = mkPreludeMiscIdUnique 252
2019 doEIdKey          = mkPreludeMiscIdUnique 253
2020 compEIdKey        = mkPreludeMiscIdUnique 254
2021 fromEIdKey        = mkPreludeMiscIdUnique 255
2022 fromThenEIdKey    = mkPreludeMiscIdUnique 256
2023 fromToEIdKey      = mkPreludeMiscIdUnique 257
2024 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
2025 listEIdKey        = mkPreludeMiscIdUnique 259
2026 sigEIdKey         = mkPreludeMiscIdUnique 260
2027 recConEIdKey      = mkPreludeMiscIdUnique 261
2028 recUpdEIdKey      = mkPreludeMiscIdUnique 262
2029
2030 -- type FieldExp = ...
2031 fieldExpIdKey :: Unique
2032 fieldExpIdKey       = mkPreludeMiscIdUnique 265
2033
2034 -- data Body = ...
2035 guardedBIdKey, normalBIdKey :: Unique
2036 guardedBIdKey     = mkPreludeMiscIdUnique 266
2037 normalBIdKey      = mkPreludeMiscIdUnique 267
2038
2039 -- data Guard = ...
2040 normalGEIdKey, patGEIdKey :: Unique
2041 normalGEIdKey     = mkPreludeMiscIdUnique 310
2042 patGEIdKey        = mkPreludeMiscIdUnique 311
2043
2044 -- data Stmt = ...
2045 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2046 bindSIdKey       = mkPreludeMiscIdUnique 268
2047 letSIdKey        = mkPreludeMiscIdUnique 269
2048 noBindSIdKey     = mkPreludeMiscIdUnique 270
2049 parSIdKey        = mkPreludeMiscIdUnique 271
2050
2051 -- data Dec = ...
2052 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2053     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2054     pragSpecDIdKey, pragSpecInlDIdKey, familyDIdKey, dataInstDIdKey,
2055     newtypeInstDIdKey, tySynInstDIdKey :: Unique
2056 funDIdKey         = mkPreludeMiscIdUnique 272
2057 valDIdKey         = mkPreludeMiscIdUnique 273
2058 dataDIdKey        = mkPreludeMiscIdUnique 274
2059 newtypeDIdKey     = mkPreludeMiscIdUnique 275
2060 tySynDIdKey       = mkPreludeMiscIdUnique 276
2061 classDIdKey       = mkPreludeMiscIdUnique 277
2062 instanceDIdKey    = mkPreludeMiscIdUnique 278
2063 sigDIdKey         = mkPreludeMiscIdUnique 279
2064 forImpDIdKey      = mkPreludeMiscIdUnique 297
2065 pragInlDIdKey     = mkPreludeMiscIdUnique 348
2066 pragSpecDIdKey    = mkPreludeMiscIdUnique 349
2067 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2068 familyDIdKey      = mkPreludeMiscIdUnique 340
2069 dataInstDIdKey    = mkPreludeMiscIdUnique 341
2070 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2071 tySynInstDIdKey   = mkPreludeMiscIdUnique 343
2072
2073 -- type Cxt = ...
2074 cxtIdKey :: Unique
2075 cxtIdKey            = mkPreludeMiscIdUnique 280
2076
2077 -- data Pred = ...
2078 classPIdKey, equalPIdKey :: Unique
2079 classPIdKey         = mkPreludeMiscIdUnique 346
2080 equalPIdKey         = mkPreludeMiscIdUnique 347
2081
2082 -- data Strict = ...
2083 isStrictKey, notStrictKey :: Unique
2084 isStrictKey         = mkPreludeMiscIdUnique 281
2085 notStrictKey        = mkPreludeMiscIdUnique 282
2086
2087 -- data Con = ...
2088 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2089 normalCIdKey      = mkPreludeMiscIdUnique 283
2090 recCIdKey         = mkPreludeMiscIdUnique 284
2091 infixCIdKey       = mkPreludeMiscIdUnique 285
2092 forallCIdKey      = mkPreludeMiscIdUnique 288
2093
2094 -- type StrictType = ...
2095 strictTKey :: Unique
2096 strictTKey        = mkPreludeMiscIdUnique 286
2097
2098 -- type VarStrictType = ...
2099 varStrictTKey :: Unique
2100 varStrictTKey     = mkPreludeMiscIdUnique 287
2101
2102 -- data Type = ...
2103 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2104     listTIdKey, appTIdKey :: Unique
2105 forallTIdKey      = mkPreludeMiscIdUnique 290
2106 varTIdKey         = mkPreludeMiscIdUnique 291
2107 conTIdKey         = mkPreludeMiscIdUnique 292
2108 tupleTIdKey       = mkPreludeMiscIdUnique 294
2109 arrowTIdKey       = mkPreludeMiscIdUnique 295
2110 listTIdKey        = mkPreludeMiscIdUnique 296
2111 appTIdKey         = mkPreludeMiscIdUnique 293
2112
2113 -- data Callconv = ...
2114 cCallIdKey, stdCallIdKey :: Unique
2115 cCallIdKey      = mkPreludeMiscIdUnique 300
2116 stdCallIdKey    = mkPreludeMiscIdUnique 301
2117
2118 -- data Safety = ...
2119 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2120 unsafeIdKey     = mkPreludeMiscIdUnique 305
2121 safeIdKey       = mkPreludeMiscIdUnique 306
2122 threadsafeIdKey = mkPreludeMiscIdUnique 307
2123
2124 -- data InlineSpec =
2125 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2126 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2127 inlineSpecPhaseIdKey   = mkPreludeMiscIdUnique 351
2128
2129 -- data FunDep = ...
2130 funDepIdKey :: Unique
2131 funDepIdKey = mkPreludeMiscIdUnique 320
2132
2133 -- data FamFlavour = ...
2134 typeFamIdKey, dataFamIdKey :: Unique
2135 typeFamIdKey = mkPreludeMiscIdUnique 344
2136 dataFamIdKey = mkPreludeMiscIdUnique 345
2137
2138 -- quasiquoting
2139 quoteExpKey, quotePatKey :: Unique
2140 quoteExpKey = mkPreludeMiscIdUnique 321
2141 quotePatKey = mkPreludeMiscIdUnique 322