compiler/deSugar/DsMeta.hs

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