compiler/deSugar/DsMeta.hs

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