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