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 <- repPred (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 typeQTyConName preds
 485                     repCtxt predList
 486
 487 -- represent a type predicate
 488 --
 489 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
 490 repLPred (L _ p) = repPred p
 491
 492 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
 493 repPred (HsClassP cls tys) = do
 494                                tcon <- repTy (HsTyVar cls)
 495                                tys1 <- repLTys tys
 496                                repTapps tcon tys1
 497 repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)
 498 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 499
 500 -- yield the representation of a list of types
 501 --
 502 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 503 repLTys tys = mapM repLTy tys
 504
 505 -- represent a type
 506 --
 507 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 508 repLTy (L _ ty) = repTy ty
 509
 510 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 511 repTy (HsForAllTy _ tvs ctxt ty)  =
 512   addTyVarBinds tvs $ \bndrs -> do
 513     ctxt1  <- repLContext ctxt
 514     ty1    <- repLTy ty
 515     bndrs1 <- coreList nameTyConName bndrs
 516     repTForall bndrs1 ctxt1 ty1
 517
 518 repTy (HsTyVar n)
 519   | isTvOcc (nameOccName n)       = do
 520                                       tv1 <- lookupTvOcc n
 521                                       repTvar tv1
 522   | otherwise                     = do
 523                                       tc1 <- lookupOcc n
 524                                       repNamedTyCon tc1
 525 repTy (HsAppTy f a)               = do
 526                                       f1 <- repLTy f
 527                                       a1 <- repLTy a
 528                                       repTapp f1 a1
 529 repTy (HsFunTy f a)               = do
 530                                       f1   <- repLTy f
 531                                       a1   <- repLTy a
 532                                       tcon <- repArrowTyCon
 533                                       repTapps tcon [f1, a1]
 534 repTy (HsListTy t)                = do
 535                                       t1   <- repLTy t
 536                                       tcon <- repListTyCon
 537                                       repTapp tcon t1
 538 repTy (HsPArrTy t)                = do
 539                                       t1   <- repLTy t
 540                                       tcon <- repTy (HsTyVar (tyConName parrTyCon))
 541                                       repTapp tcon t1
 542 repTy (HsTupleTy _ tys)   = do
 543                                       tys1 <- repLTys tys
 544                                       tcon <- repTupleTyCon (length tys)
 545                                       repTapps tcon tys1
 546 repTy (HsOpTy ty1 n ty2)          = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 547                                            `nlHsAppTy` ty2)
 548 repTy (HsParTy t)                 = repLTy t
 549 repTy (HsPredTy pred)             = repPred pred
 550 repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
 551 repTy ty                          = notHandled "Exotic form of type" (ppr ty)
 552
 553
 554 -----------------------------------------------------------------------------
 555 --              Expressions
 556 -----------------------------------------------------------------------------
 557
 558 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
 559 repLEs es = do { es'  <- mapM repLE es ;
 560                  coreList expQTyConName es' }
 561
 562 -- FIXME: some of these panics should be converted into proper error messages
 563 --        unless we can make sure that constructs, which are plainly not
 564 --        supported in TH already lead to error messages at an earlier stage
 565 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
 566 repLE (L loc e) = putSrcSpanDs loc (repE e)
 567
 568 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 569 repE (HsVar x)            =
 570   do { mb_val <- dsLookupMetaEnv x
 571      ; case mb_val of
 572         Nothing          -> do { str <- globalVar x
 573                                ; repVarOrCon x str }
 574         Just (Bound y)   -> repVarOrCon x (coreVar y)
 575         Just (Splice e)  -> do { e' <- dsExpr e
 576                                ; return (MkC e') } }
 577 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 578
 579         -- Remember, we're desugaring renamer output here, so
 580         -- HsOverlit can definitely occur
 581 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 582 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 583 repE (HsLam (MatchGroup [m] _)) = repLambda m
 584 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 585
 586 repE (OpApp e1 op _ e2) =
 587   do { arg1 <- repLE e1;
 588        arg2 <- repLE e2;
 589        the_op <- repLE op ;
 590        repInfixApp arg1 the_op arg2 }
 591 repE (NegApp x _)        = do
 592                               a         <- repLE x
 593                               negateVar <- lookupOcc negateName >>= repVar
 594                               negateVar `repApp` a
 595 repE (HsPar x)            = repLE x
 596 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 597 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 598 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 599                                        ; ms2 <- mapM repMatchTup ms
 600                                        ; repCaseE arg (nonEmptyCoreList ms2) }
 601 repE (HsIf x y z)         = do
 602                               a <- repLE x
 603                               b <- repLE y
 604                               c <- repLE z
 605                               repCond a b c
 606 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 607                                ; e2 <- addBinds ss (repLE e)
 608                                ; z <- repLetE ds e2
 609                                ; wrapGenSyns ss z }
 610 -- FIXME: I haven't got the types here right yet
 611 repE (HsDo DoExpr sts body _)
 612  = do { (ss,zs) <- repLSts sts;
 613         body'   <- addBinds ss $ repLE body;
 614         ret     <- repNoBindSt body';
 615         e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
 616         wrapGenSyns ss e }
 617 repE (HsDo ListComp sts body _)
 618  = do { (ss,zs) <- repLSts sts;
 619         body'   <- addBinds ss $ repLE body;
 620         ret     <- repNoBindSt body';
 621         e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
 622         wrapGenSyns ss e }
 623 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
 624 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 625 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 626 repE e@(ExplicitTuple es boxed)
 627   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
 628   | otherwise             = notHandled "Unboxed tuples" (ppr e)
 629 repE (RecordCon c _ flds)
 630  = do { x <- lookupLOcc c;
 631         fs <- repFields flds;
 632         repRecCon x fs }
 633 repE (RecordUpd e flds _ _ _)
 634  = do { x <- repLE e;
 635         fs <- repFields flds;
 636         repRecUpd x fs }
 637
 638 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
 639 repE (ArithSeq _ aseq) =
 640   case aseq of
 641     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 642     FromThen e1 e2      -> do
 643                              ds1 <- repLE e1
 644                              ds2 <- repLE e2
 645                              repFromThen ds1 ds2
 646     FromTo   e1 e2      -> do
 647                              ds1 <- repLE e1
 648                              ds2 <- repLE e2
 649                              repFromTo ds1 ds2
 650     FromThenTo e1 e2 e3 -> do
 651                              ds1 <- repLE e1
 652                              ds2 <- repLE e2
 653                              ds3 <- repLE e3
 654                              repFromThenTo ds1 ds2 ds3
 655 repE (HsSpliceE (HsSplice n _))
 656   = do { mb_val <- dsLookupMetaEnv n
 657        ; case mb_val of
 658                  Just (Splice e) -> do { e' <- dsExpr e
 659                                        ; return (MkC e') }
 660                  _ -> pprPanic "HsSplice" (ppr n) }
 661                         -- Should not happen; statically checked
 662
 663 repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
 664 repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
 665 repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
 666 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
 667 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
 668 repE e                   = notHandled "Expression form" (ppr e)
 669
 670 -----------------------------------------------------------------------------
 671 -- Building representations of auxillary structures like Match, Clause, Stmt,
 672
 673 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
 674 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
 675   do { ss1 <- mkGenSyms (collectPatBinders p)
 676      ; addBinds ss1 $ do {
 677      ; p1 <- repLP p
 678      ; (ss2,ds) <- repBinds wheres
 679      ; addBinds ss2 $ do {
 680      ; gs    <- repGuards guards
 681      ; match <- repMatch p1 gs ds
 682      ; wrapGenSyns (ss1++ss2) match }}}
 683 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 684
 685 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
 686 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
 687   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 688      ; addBinds ss1 $ do {
 689        ps1 <- repLPs ps
 690      ; (ss2,ds) <- repBinds wheres
 691      ; addBinds ss2 $ do {
 692        gs <- repGuards guards
 693      ; clause <- repClause ps1 gs ds
 694      ; wrapGenSyns (ss1++ss2) clause }}}
 695
 696 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 697 repGuards [L _ (GRHS [] e)]
 698   = do {a <- repLE e; repNormal a }
 699 repGuards other
 700   = do { zs <- mapM process other;
 701      let {(xs, ys) = unzip zs};
 702          gd <- repGuarded (nonEmptyCoreList ys);
 703      wrapGenSyns (concat xs) gd }
 704   where
 705     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
 706     process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
 707            = do { x <- repLNormalGE e1 e2;
 708                   return ([], x) }
 709     process (L _ (GRHS ss rhs))
 710            = do (gs, ss') <- repLSts ss
 711                 rhs' <- addBinds gs $ repLE rhs
 712                 g <- repPatGE (nonEmptyCoreList ss') rhs'
 713                 return (gs, g)
 714
 715 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 716 repFields (HsRecFields { rec_flds = flds })
 717   = do  { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
 718         ; es <- mapM repLE (map hsRecFieldArg flds)
 719         ; fs <- zipWithM repFieldExp fnames es
 720         ; coreList fieldExpQTyConName fs }
 721
 722
 723 -----------------------------------------------------------------------------
 724 -- Representing Stmt's is tricky, especially if bound variables
 725 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 726 -- First gensym new names for every variable in any of the patterns.
 727 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 728 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 729 -- and we could reuse the original names (x and x).
 730 --
 731 -- do { x'1 <- gensym "x"
 732 --    ; x'2 <- gensym "x"
 733 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 734 --          , BindSt (pvar x'2) [| f x |]
 735 --          , NoBindSt [| g x |]
 736 --          ]
 737 --    }
 738
 739 -- The strategy is to translate a whole list of do-bindings by building a
 740 -- bigger environment, and a bigger set of meta bindings
 741 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 742 -- of the expressions within the Do
 743
 744 -----------------------------------------------------------------------------
 745 -- The helper function repSts computes the translation of each sub expression
 746 -- and a bunch of prefix bindings denoting the dynamic renaming.
 747
 748 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 749 repLSts stmts = repSts (map unLoc stmts)
 750
 751 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 752 repSts (BindStmt p e _ _ : ss) =
 753    do { e2 <- repLE e
 754       ; ss1 <- mkGenSyms (collectPatBinders p)
 755       ; addBinds ss1 $ do {
 756       ; p1 <- repLP p;
 757       ; (ss2,zs) <- repSts ss
 758       ; z <- repBindSt p1 e2
 759       ; return (ss1++ss2, z : zs) }}
 760 repSts (LetStmt bs : ss) =
 761    do { (ss1,ds) <- repBinds bs
 762       ; z <- repLetSt ds
 763       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 764       ; return (ss1++ss2, z : zs) }
 765 repSts (ExprStmt e _ _ : ss) =
 766    do { e2 <- repLE e
 767       ; z <- repNoBindSt e2
 768       ; (ss2,zs) <- repSts ss
 769       ; return (ss2, z : zs) }
 770 repSts []    = return ([],[])
 771 repSts other = notHandled "Exotic statement" (ppr other)
 772
 773
 774 -----------------------------------------------------------
 775 --                      Bindings
 776 -----------------------------------------------------------
 777
 778 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 779 repBinds EmptyLocalBinds
 780   = do  { core_list <- coreList decQTyConName []
 781         ; return ([], core_list) }
 782
 783 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
 784
 785 repBinds (HsValBinds decs)
 786  = do   { let { bndrs = map unLoc (collectHsValBinders decs) }
 787                 -- No need to worrry about detailed scopes within
 788                 -- the binding group, because we are talking Names
 789                 -- here, so we can safely treat it as a mutually
 790                 -- recursive group
 791         ; ss        <- mkGenSyms bndrs
 792         ; prs       <- addBinds ss (rep_val_binds decs)
 793         ; core_list <- coreList decQTyConName
 794                                 (de_loc (sort_by_loc prs))
 795         ; return (ss, core_list) }
 796
 797 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 798 -- Assumes: all the binders of the binding are alrady in the meta-env
 799 rep_val_binds (ValBindsOut binds sigs)
 800  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
 801       ; core2 <- rep_sigs' sigs
 802       ; return (core1 ++ core2) }
 803 rep_val_binds (ValBindsIn _ _)
 804  = panic "rep_val_binds: ValBindsIn"
 805
 806 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 807 rep_binds binds = do { binds_w_locs <- rep_binds' binds
 808                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 809
 810 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 811 rep_binds' binds = mapM rep_bind (bagToList binds)
 812
 813 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 814 -- Assumes: all the binders of the binding are alrady in the meta-env
 815
 816 -- Note GHC treats declarations of a variable (not a pattern)
 817 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 818 -- with an empty list of patterns
 819 rep_bind (L loc (FunBind { fun_id = fn,
 820                            fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
 821  = do { (ss,wherecore) <- repBinds wheres
 822         ; guardcore <- addBinds ss (repGuards guards)
 823         ; fn'  <- lookupLBinder fn
 824         ; p    <- repPvar fn'
 825         ; ans  <- repVal p guardcore wherecore
 826         ; ans' <- wrapGenSyns ss ans
 827         ; return (loc, ans') }
 828
 829 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 830  =   do { ms1 <- mapM repClauseTup ms
 831         ; fn' <- lookupLBinder fn
 832         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 833         ; return (loc, ans) }
 834
 835 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 836  =   do { patcore <- repLP pat
 837         ; (ss,wherecore) <- repBinds wheres
 838         ; guardcore <- addBinds ss (repGuards guards)
 839         ; ans  <- repVal patcore guardcore wherecore
 840         ; ans' <- wrapGenSyns ss ans
 841         ; return (loc, ans') }
 842
 843 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
 844  =   do { v' <- lookupBinder v
 845         ; e2 <- repLE e
 846         ; x <- repNormal e2
 847         ; patcore <- repPvar v'
 848         ; empty_decls <- coreList decQTyConName []
 849         ; ans <- repVal patcore x empty_decls
 850         ; return (srcLocSpan (getSrcLoc v), ans) }
 851
 852 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
 853
 854 -----------------------------------------------------------------------------
 855 -- Since everything in a Bind is mutually recursive we need rename all
 856 -- all the variables simultaneously. For example:
 857 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 858 -- do { f'1 <- gensym "f"
 859 --    ; g'2 <- gensym "g"
 860 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 861 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 862 --      ]}
 863 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 864 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 865 -- together. As we do this we collect GenSymBinds's which represent the renamed
 866 -- variables bound by the Bindings. In order not to lose track of these
 867 -- representations we build a shadow datatype MB with the same structure as
 868 -- MonoBinds, but which has slots for the representations
 869
 870
 871 -----------------------------------------------------------------------------
 872 -- GHC allows a more general form of lambda abstraction than specified
 873 -- by Haskell 98. In particular it allows guarded lambda's like :
 874 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 875 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 876 -- (\ p1 .. pn -> exp) by causing an error.
 877
 878 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
 879 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 880  = do { let bndrs = collectPatsBinders ps ;
 881       ; ss  <- mkGenSyms bndrs
 882       ; lam <- addBinds ss (
 883                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 884       ; wrapGenSyns ss lam }
 885
 886 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
 887
 888
 889 -----------------------------------------------------------------------------
 890 --                      Patterns
 891 -- repP deals with patterns.  It assumes that we have already
 892 -- walked over the pattern(s) once to collect the binders, and
 893 -- have extended the environment.  So every pattern-bound
 894 -- variable should already appear in the environment.
 895
 896 -- Process a list of patterns
 897 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
 898 repLPs ps = do { ps' <- mapM repLP ps ;
 899                  coreList patQTyConName ps' }
 900
 901 repLP :: LPat Name -> DsM (Core TH.PatQ)
 902 repLP (L _ p) = repP p
 903
 904 repP :: Pat Name -> DsM (Core TH.PatQ)
 905 repP (WildPat _)       = repPwild
 906 repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
 907 repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
 908 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
 909 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
 910 repP (ParPat p)        = repLP p
 911 repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
 912 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 913 repP (ConPatIn dc details)
 914  = do { con_str <- lookupLOcc dc
 915       ; case details of
 916          PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
 917          RecCon rec   -> do { let flds = rec_flds rec
 918                             ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
 919                             ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
 920                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
 921                             ; fps' <- coreList fieldPatQTyConName fps
 922                             ; repPrec con_str fps' }
 923          InfixCon p1 p2 -> do { p1' <- repLP p1;
 924                                 p2' <- repLP p2;
 925                                 repPinfix p1' con_str p2' }
 926    }
 927 repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
 928 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
 929 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
 930         -- The problem is to do with scoped type variables.
 931         -- To implement them, we have to implement the scoping rules
 932         -- here in DsMeta, and I don't want to do that today!
 933         --       do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 934         --      repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
 935         --      repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
 936
 937 repP other = notHandled "Exotic pattern" (ppr other)
 938
 939 ----------------------------------------------------------
 940 -- Declaration ordering helpers
 941
 942 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
 943 sort_by_loc xs = sortBy comp xs
 944     where comp x y = compare (fst x) (fst y)
 945
 946 de_loc :: [(a, b)] -> [b]
 947 de_loc = map snd
 948
 949 ----------------------------------------------------------
 950 --      The meta-environment
 951
 952 -- A name/identifier association for fresh names of locally bound entities
 953 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 954                                 -- I.e.         (x, x_id) means
 955                                 --      let x_id = gensym "x" in ...
 956
 957 -- Generate a fresh name for a locally bound entity
 958
 959 mkGenSyms :: [Name] -> DsM [GenSymBind]
 960 -- We can use the existing name.  For example:
 961 --      [| \x_77 -> x_77 + x_77 |]
 962 -- desugars to
 963 --      do { x_77 <- genSym "x"; .... }
 964 -- We use the same x_77 in the desugared program, but with the type Bndr
 965 -- instead of Int
 966 --
 967 -- We do make it an Internal name, though (hence localiseName)
 968 --
 969 -- Nevertheless, it's monadic because we have to generate nameTy
 970 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
 971                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
 972
 973
 974 addBinds :: [GenSymBind] -> DsM a -> DsM a
 975 -- Add a list of fresh names for locally bound entities to the
 976 -- meta environment (which is part of the state carried around
 977 -- by the desugarer monad)
 978 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 979
 980 -- Look up a locally bound name
 981 --
 982 lookupLBinder :: Located Name -> DsM (Core TH.Name)
 983 lookupLBinder (L _ n) = lookupBinder n
 984
 985 lookupBinder :: Name -> DsM (Core TH.Name)
 986 lookupBinder n
 987   = do { mb_val <- dsLookupMetaEnv n;
 988          case mb_val of
 989             Just (Bound x) -> return (coreVar x)
 990             _              -> failWithDs msg }
 991   where
 992     msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
 993
 994 -- Look up a name that is either locally bound or a global name
 995 --
 996 --  * If it is a global name, generate the "original name" representation (ie,
 997 --   the <module>:<name> form) for the associated entity
 998 --
 999 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1000 -- Lookup an occurrence; it can't be a splice.
1001 -- Use the in-scope bindings if they exist
1002 lookupLOcc (L _ n) = lookupOcc n
1003
1004 lookupOcc :: Name -> DsM (Core TH.Name)
1005 lookupOcc n
1006   = do {  mb_val <- dsLookupMetaEnv n ;
1007           case mb_val of
1008                 Nothing         -> globalVar n
1009                 Just (Bound x)  -> return (coreVar x)
1010                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1011     }
1012
1013 lookupTvOcc :: Name -> DsM (Core TH.Name)
1014 -- Type variables can't be staged and are not lexically scoped in TH
1015 lookupTvOcc n
1016   = do {  mb_val <- dsLookupMetaEnv n ;
1017           case mb_val of
1018                 Just (Bound x)  -> return (coreVar x)
1019                 _               -> failWithDs msg
1020     }
1021   where
1022     msg = vcat  [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1023                 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1024
1025 globalVar :: Name -> DsM (Core TH.Name)
1026 -- Not bound by the meta-env
1027 -- Could be top-level; or could be local
1028 --      f x = $(g [| x |])
1029 -- Here the x will be local
1030 globalVar name
1031   | isExternalName name
1032   = do  { MkC mod <- coreStringLit name_mod
1033         ; MkC pkg <- coreStringLit name_pkg
1034         ; MkC occ <- occNameLit name
1035         ; rep2 mk_varg [pkg,mod,occ] }
1036   | otherwise
1037   = do  { MkC occ <- occNameLit name
1038         ; MkC uni <- coreIntLit (getKey (getUnique name))
1039         ; rep2 mkNameLName [occ,uni] }
1040   where
1041       mod = ASSERT( isExternalName name) nameModule name
1042       name_mod = moduleNameString (moduleName mod)
1043       name_pkg = packageIdString (modulePackageId mod)
1044       name_occ = nameOccName name
1045       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1046               | OccName.isVarOcc  name_occ = mkNameG_vName
1047               | OccName.isTcOcc   name_occ = mkNameG_tcName
1048               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
1049
1050 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
1051            -> DsM Type  -- The type
1052 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1053                           return (mkTyConApp tc []) }
1054
1055 wrapGenSyns :: [GenSymBind]
1056             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1057 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
1058 --      --> bindQ (gensym nm1) (\ id1 ->
1059 --          bindQ (gensym nm2 (\ id2 ->
1060 --          y))
1061
1062 wrapGenSyns binds body@(MkC b)
1063   = do  { var_ty <- lookupType nameTyConName
1064         ; go var_ty binds }
1065   where
1066     [elt_ty] = tcTyConAppArgs (exprType b)
1067         -- b :: Q a, so we can get the type 'a' by looking at the
1068         -- argument type. NB: this relies on Q being a data/newtype,
1069         -- not a type synonym
1070
1071     go _ [] = return body
1072     go var_ty ((name,id) : binds)
1073       = do { MkC body'  <- go var_ty binds
1074            ; lit_str    <- occNameLit name
1075            ; gensym_app <- repGensym lit_str
1076            ; repBindQ var_ty elt_ty
1077                       gensym_app (MkC (Lam id body')) }
1078
1079 -- Just like wrapGenSym, but don't actually do the gensym
1080 -- Instead use the existing name:
1081 --      let x = "x" in ...
1082 -- Only used for [Decl], and for the class ops in class
1083 -- and instance decls
1084 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1085 wrapNongenSyms binds (MkC body)
1086   = do { binds' <- mapM do_one binds ;
1087          return (MkC (mkLets binds' body)) }
1088   where
1089     do_one (name,id)
1090         = do { MkC lit_str <- occNameLit name
1091              ; MkC var <- rep2 mkNameName [lit_str]
1092              ; return (NonRec id var) }
1093
1094 occNameLit :: Name -> DsM (Core String)
1095 occNameLit n = coreStringLit (occNameString (nameOccName n))
1096
1097
1098 -- %*********************************************************************
1099 -- %*                                                                   *
1100 --              Constructing code
1101 -- %*                                                                   *
1102 -- %*********************************************************************
1103
1104 -----------------------------------------------------------------------------
1105 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1106 -- we invent a new datatype which uses phantom types.
1107
1108 newtype Core a = MkC CoreExpr
1109 unC :: Core a -> CoreExpr
1110 unC (MkC x) = x
1111
1112 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1113 rep2 n xs = do { id <- dsLookupGlobalId n
1114                ; return (MkC (foldl App (Var id) xs)) }
1115
1116 -- Then we make "repConstructors" which use the phantom types for each of the
1117 -- smart constructors of the Meta.Meta datatypes.
1118
1119
1120 -- %*********************************************************************
1121 -- %*                                                                   *
1122 --              The 'smart constructors'
1123 -- %*                                                                   *
1124 -- %*********************************************************************
1125
1126 --------------- Patterns -----------------
1127 repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
1128 repPlit (MkC l) = rep2 litPName [l]
1129
1130 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1131 repPvar (MkC s) = rep2 varPName [s]
1132
1133 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1134 repPtup (MkC ps) = rep2 tupPName [ps]
1135
1136 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1137 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1138
1139 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1140 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1141
1142 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1143 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1144
1145 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1146 repPtilde (MkC p) = rep2 tildePName [p]
1147
1148 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1149 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1150
1151 repPwild  :: DsM (Core TH.PatQ)
1152 repPwild = rep2 wildPName []
1153
1154 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1155 repPlist (MkC ps) = rep2 listPName [ps]
1156
1157 --------------- Expressions -----------------
1158 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1159 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1160                    | otherwise                  = repVar str
1161
1162 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1163 repVar (MkC s) = rep2 varEName [s]
1164
1165 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1166 repCon (MkC s) = rep2 conEName [s]
1167
1168 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1169 repLit (MkC c) = rep2 litEName [c]
1170
1171 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1172 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1173
1174 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1175 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1176
1177 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1178 repTup (MkC es) = rep2 tupEName [es]
1179
1180 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1181 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
1182
1183 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1184 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1185
1186 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1187 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1188
1189 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1190 repDoE (MkC ss) = rep2 doEName [ss]
1191
1192 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1193 repComp (MkC ss) = rep2 compEName [ss]
1194
1195 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1196 repListExp (MkC es) = rep2 listEName [es]
1197
1198 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1199 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1200
1201 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1202 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1203
1204 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1205 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1206
1207 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1208 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1209
1210 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1211 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1212
1213 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1214 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1215
1216 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1217 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1218
1219 ------------ Right hand sides (guarded expressions) ----
1220 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1221 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1222
1223 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1224 repNormal (MkC e) = rep2 normalBName [e]
1225
1226 ------------ Guards ----
1227 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1228 repLNormalGE g e = do g' <- repLE g
1229                       e' <- repLE e
1230                       repNormalGE g' e'
1231
1232 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1233 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1234
1235 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1236 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1237
1238 ------------- Stmts -------------------
1239 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1240 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1241
1242 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1243 repLetSt (MkC ds) = rep2 letSName [ds]
1244
1245 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1246 repNoBindSt (MkC e) = rep2 noBindSName [e]
1247
1248 -------------- Range (Arithmetic sequences) -----------
1249 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1250 repFrom (MkC x) = rep2 fromEName [x]
1251
1252 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1253 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1254
1255 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1256 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1257
1258 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1259 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1260
1261 ------------ Match and Clause Tuples -----------
1262 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1263 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1264
1265 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1266 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1267
1268 -------------- Dec -----------------------------
1269 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1270 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1271
1272 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1273 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1274
1275 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name]
1276         -> Maybe (Core [TH.TypeQ])
1277         -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1278 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1279   = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1280 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1281   = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1282
1283 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name]
1284            -> Maybe (Core [TH.TypeQ])
1285            -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1286 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1287   = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1288 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1289   = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1290
1291 repTySyn :: Core TH.Name -> Core [TH.Name]
1292          -> Maybe (Core [TH.TypeQ])
1293          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1294 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1295   = rep2 tySynDName [nm, tvs, rhs]
1296 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1297   = rep2 tySynInstDName [nm, tys, rhs]
1298
1299 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1300 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1301
1302 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1303 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1304
1305 repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name]
1306           -> DsM (Core TH.DecQ)
1307 repFamily (MkC flav) (MkC nm) (MkC tvs)
1308     = rep2 familyDName [flav, nm, tvs]
1309
1310 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1311 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1312
1313 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1314 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1315
1316 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1317 repCtxt (MkC tys) = rep2 cxtName [tys]
1318
1319 repConstr :: Core TH.Name -> HsConDeclDetails Name
1320           -> DsM (Core TH.ConQ)
1321 repConstr con (PrefixCon ps)
1322     = do arg_tys  <- mapM repBangTy ps
1323          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1324          rep2 normalCName [unC con, unC arg_tys1]
1325 repConstr con (RecCon ips)
1326     = do arg_vs   <- mapM lookupLOcc (map cd_fld_name ips)
1327          arg_tys  <- mapM repBangTy (map cd_fld_type ips)
1328          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1329                               arg_vs arg_tys
1330          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1331          rep2 recCName [unC con, unC arg_vtys']
1332 repConstr con (InfixCon st1 st2)
1333     = do arg1 <- repBangTy st1
1334          arg2 <- repBangTy st2
1335          rep2 infixCName [unC arg1, unC con, unC arg2]
1336
1337 ------------ Types -------------------
1338
1339 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1340 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1341     = rep2 forallTName [tvars, ctxt, ty]
1342
1343 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1344 repTvar (MkC s) = rep2 varTName [s]
1345
1346 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1347 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1348
1349 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1350 repTapps f []     = return f
1351 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1352
1353 --------- Type constructors --------------
1354
1355 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1356 repNamedTyCon (MkC s) = rep2 conTName [s]
1357
1358 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1359 -- Note: not Core Int; it's easier to be direct here
1360 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1361
1362 repArrowTyCon :: DsM (Core TH.TypeQ)
1363 repArrowTyCon = rep2 arrowTName []
1364
1365 repListTyCon :: DsM (Core TH.TypeQ)
1366 repListTyCon = rep2 listTName []
1367
1368
1369 ----------------------------------------------------------
1370 --              Literals
1371
1372 repLiteral :: HsLit -> DsM (Core TH.Lit)
1373 repLiteral lit
1374   = do lit' <- case lit of
1375                    HsIntPrim i    -> mk_integer i
1376                    HsWordPrim w   -> mk_integer w
1377                    HsInt i        -> mk_integer i
1378                    HsFloatPrim r  -> mk_rational r
1379                    HsDoublePrim r -> mk_rational r
1380                    _ -> return lit
1381        lit_expr <- dsLit lit'
1382        case mb_lit_name of
1383           Just lit_name -> rep2 lit_name [lit_expr]
1384           Nothing -> notHandled "Exotic literal" (ppr lit)
1385   where
1386     mb_lit_name = case lit of
1387                  HsInteger _ _  -> Just integerLName
1388                  HsInt     _    -> Just integerLName
1389                  HsIntPrim _    -> Just intPrimLName
1390                  HsWordPrim _   -> Just wordPrimLName
1391                  HsFloatPrim _  -> Just floatPrimLName
1392                  HsDoublePrim _ -> Just doublePrimLName
1393                  HsChar _       -> Just charLName
1394                  HsString _     -> Just stringLName
1395                  HsRat _ _      -> Just rationalLName
1396                  _              -> Nothing
1397
1398 mk_integer :: Integer -> DsM HsLit
1399 mk_integer  i = do integer_ty <- lookupType integerTyConName
1400                    return $ HsInteger i integer_ty
1401 mk_rational :: Rational -> DsM HsLit
1402 mk_rational r = do rat_ty <- lookupType rationalTyConName
1403                    return $ HsRat r rat_ty
1404 mk_string :: FastString -> DsM HsLit
1405 mk_string s = return $ HsString s
1406
1407 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1408 repOverloadedLiteral (OverLit { ol_val = val})
1409   = do { lit <- mk_lit val; repLiteral lit }
1410         -- The type Rational will be in the environment, becuase
1411         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1412         -- and rationalL is sucked in when any TH stuff is used
1413
1414 mk_lit :: OverLitVal -> DsM HsLit
1415 mk_lit (HsIntegral i)   = mk_integer  i
1416 mk_lit (HsFractional f) = mk_rational f
1417 mk_lit (HsIsString s)   = mk_string   s
1418
1419 --------------- Miscellaneous -------------------
1420
1421 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1422 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1423
1424 repBindQ :: Type -> Type        -- a and b
1425          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1426 repBindQ ty_a ty_b (MkC x) (MkC y)
1427   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1428
1429 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1430 repSequenceQ ty_a (MkC list)
1431   = rep2 sequenceQName [Type ty_a, list]
1432
1433 ------------ Lists and Tuples -------------------
1434 -- turn a list of patterns into a single pattern matching a list
1435
1436 coreList :: Name        -- Of the TyCon of the element type
1437          -> [Core a] -> DsM (Core [a])
1438 coreList tc_name es
1439   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1440
1441 coreList' :: Type       -- The element type
1442           -> [Core a] -> Core [a]
1443 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1444
1445 nonEmptyCoreList :: [Core a] -> Core [a]
1446   -- The list must be non-empty so we can get the element type
1447   -- Otherwise use coreList
1448 nonEmptyCoreList []           = panic "coreList: empty argument"
1449 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1450
1451 coreStringLit :: String -> DsM (Core String)
1452 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1453
1454 coreIntLit :: Int -> DsM (Core Int)
1455 coreIntLit i = return (MkC (mkIntExprInt i))
1456
1457 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1458 coreVar id = MkC (Var id)
1459
1460 ----------------- Failure -----------------------
1461 notHandled :: String -> SDoc -> DsM a
1462 notHandled what doc = failWithDs msg
1463   where
1464     msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1465              2 doc
1466
1467
1468 -- %************************************************************************
1469 -- %*                                                                   *
1470 --              The known-key names for Template Haskell
1471 -- %*                                                                   *
1472 -- %************************************************************************
1473
1474 -- To add a name, do three things
1475 --
1476 --  1) Allocate a key
1477 --  2) Make a "Name"
1478 --  3) Add the name to knownKeyNames
1479
1480 templateHaskellNames :: [Name]
1481 -- The names that are implicitly mentioned by ``bracket''
1482 -- Should stay in sync with the import list of DsMeta
1483
1484 templateHaskellNames = [
1485     returnQName, bindQName, sequenceQName, newNameName, liftName,
1486     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1487
1488     -- Lit
1489     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1490     floatPrimLName, doublePrimLName, rationalLName,
1491     -- Pat
1492     litPName, varPName, tupPName, conPName, tildePName, infixPName,
1493     asPName, wildPName, recPName, listPName, sigPName,
1494     -- FieldPat
1495     fieldPatName,
1496     -- Match
1497     matchName,
1498     -- Clause
1499     clauseName,
1500     -- Exp
1501     varEName, conEName, litEName, appEName, infixEName,
1502     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1503     condEName, letEName, caseEName, doEName, compEName,
1504     fromEName, fromThenEName, fromToEName, fromThenToEName,
1505     listEName, sigEName, recConEName, recUpdEName,
1506     -- FieldExp
1507     fieldExpName,
1508     -- Body
1509     guardedBName, normalBName,
1510     -- Guard
1511     normalGEName, patGEName,
1512     -- Stmt
1513     bindSName, letSName, noBindSName, parSName,
1514     -- Dec
1515     funDName, valDName, dataDName, newtypeDName, tySynDName,
1516     classDName, instanceDName, sigDName, forImpDName, familyDName, dataInstDName,
1517     newtypeInstDName, tySynInstDName,
1518     -- Cxt
1519     cxtName,
1520     -- Strict
1521     isStrictName, notStrictName,
1522     -- Con
1523     normalCName, recCName, infixCName, forallCName,
1524     -- StrictType
1525     strictTypeName,
1526     -- VarStrictType
1527     varStrictTypeName,
1528     -- Type
1529     forallTName, varTName, conTName, appTName,
1530     tupleTName, arrowTName, listTName,
1531     -- Callconv
1532     cCallName, stdCallName,
1533     -- Safety
1534     unsafeName,
1535     safeName,
1536     threadsafeName,
1537     -- FunDep
1538     funDepName,
1539     -- FamFlavour
1540     typeFamName, dataFamName,
1541
1542     -- And the tycons
1543     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1544     clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1545     decQTyConName, conQTyConName, strictTypeQTyConName,
1546     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1547     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1548     fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1549
1550     -- Quasiquoting
1551     quoteExpName, quotePatName]
1552
1553 thSyn, thLib, qqLib :: Module
1554 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1555 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1556 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1557
1558 mkTHModule :: FastString -> Module
1559 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1560
1561 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1562 libFun = mk_known_key_name OccName.varName thLib
1563 libTc  = mk_known_key_name OccName.tcName  thLib
1564 thFun  = mk_known_key_name OccName.varName thSyn
1565 thTc   = mk_known_key_name OccName.tcName  thSyn
1566 qqFun  = mk_known_key_name OccName.varName qqLib
1567
1568 -------------------- TH.Syntax -----------------------
1569 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1570     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1571     matchTyConName, clauseTyConName, funDepTyConName :: Name
1572 qTyConName        = thTc (fsLit "Q")            qTyConKey
1573 nameTyConName     = thTc (fsLit "Name")         nameTyConKey
1574 fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey
1575 patTyConName      = thTc (fsLit "Pat")          patTyConKey
1576 fieldPatTyConName = thTc (fsLit "FieldPat")     fieldPatTyConKey
1577 expTyConName      = thTc (fsLit "Exp")          expTyConKey
1578 decTyConName      = thTc (fsLit "Dec")          decTyConKey
1579 typeTyConName     = thTc (fsLit "Type")         typeTyConKey
1580 matchTyConName    = thTc (fsLit "Match")        matchTyConKey
1581 clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey
1582 funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey
1583
1584 returnQName, bindQName, sequenceQName, newNameName, liftName,
1585     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1586     mkNameLName :: Name
1587 returnQName   = thFun (fsLit "returnQ")   returnQIdKey
1588 bindQName     = thFun (fsLit "bindQ")     bindQIdKey
1589 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1590 newNameName    = thFun (fsLit "newName")   newNameIdKey
1591 liftName      = thFun (fsLit "lift")      liftIdKey
1592 mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
1593 mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
1594 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
1595 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1596 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
1597
1598
1599 -------------------- TH.Lib -----------------------
1600 -- data Lit = ...
1601 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1602     floatPrimLName, doublePrimLName, rationalLName :: Name
1603 charLName       = libFun (fsLit "charL")       charLIdKey
1604 stringLName     = libFun (fsLit "stringL")     stringLIdKey
1605 integerLName    = libFun (fsLit "integerL")    integerLIdKey
1606 intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
1607 wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
1608 floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
1609 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1610 rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
1611
1612 -- data Pat = ...
1613 litPName, varPName, tupPName, conPName, infixPName, tildePName,
1614     asPName, wildPName, recPName, listPName, sigPName :: Name
1615 litPName   = libFun (fsLit "litP")   litPIdKey
1616 varPName   = libFun (fsLit "varP")   varPIdKey
1617 tupPName   = libFun (fsLit "tupP")   tupPIdKey
1618 conPName   = libFun (fsLit "conP")   conPIdKey
1619 infixPName = libFun (fsLit "infixP") infixPIdKey
1620 tildePName = libFun (fsLit "tildeP") tildePIdKey
1621 asPName    = libFun (fsLit "asP")    asPIdKey
1622 wildPName  = libFun (fsLit "wildP")  wildPIdKey
1623 recPName   = libFun (fsLit "recP")   recPIdKey
1624 listPName  = libFun (fsLit "listP")  listPIdKey
1625 sigPName   = libFun (fsLit "sigP")   sigPIdKey
1626
1627 -- type FieldPat = ...
1628 fieldPatName :: Name
1629 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1630
1631 -- data Match = ...
1632 matchName :: Name
1633 matchName = libFun (fsLit "match") matchIdKey
1634
1635 -- data Clause = ...
1636 clauseName :: Name
1637 clauseName = libFun (fsLit "clause") clauseIdKey
1638
1639 -- data Exp = ...
1640 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1641     sectionLName, sectionRName, lamEName, tupEName, condEName,
1642     letEName, caseEName, doEName, compEName :: Name
1643 varEName        = libFun (fsLit "varE")        varEIdKey
1644 conEName        = libFun (fsLit "conE")        conEIdKey
1645 litEName        = libFun (fsLit "litE")        litEIdKey
1646 appEName        = libFun (fsLit "appE")        appEIdKey
1647 infixEName      = libFun (fsLit "infixE")      infixEIdKey
1648 infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
1649 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
1650 sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
1651 lamEName        = libFun (fsLit "lamE")        lamEIdKey
1652 tupEName        = libFun (fsLit "tupE")        tupEIdKey
1653 condEName       = libFun (fsLit "condE")       condEIdKey
1654 letEName        = libFun (fsLit "letE")        letEIdKey
1655 caseEName       = libFun (fsLit "caseE")       caseEIdKey
1656 doEName         = libFun (fsLit "doE")         doEIdKey
1657 compEName       = libFun (fsLit "compE")       compEIdKey
1658 -- ArithSeq skips a level
1659 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1660 fromEName       = libFun (fsLit "fromE")       fromEIdKey
1661 fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey
1662 fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey
1663 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1664 -- end ArithSeq
1665 listEName, sigEName, recConEName, recUpdEName :: Name
1666 listEName       = libFun (fsLit "listE")       listEIdKey
1667 sigEName        = libFun (fsLit "sigE")        sigEIdKey
1668 recConEName     = libFun (fsLit "recConE")     recConEIdKey
1669 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
1670
1671 -- type FieldExp = ...
1672 fieldExpName :: Name
1673 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1674
1675 -- data Body = ...
1676 guardedBName, normalBName :: Name
1677 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1678 normalBName  = libFun (fsLit "normalB")  normalBIdKey
1679
1680 -- data Guard = ...
1681 normalGEName, patGEName :: Name
1682 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1683 patGEName    = libFun (fsLit "patGE")    patGEIdKey
1684
1685 -- data Stmt = ...
1686 bindSName, letSName, noBindSName, parSName :: Name
1687 bindSName   = libFun (fsLit "bindS")   bindSIdKey
1688 letSName    = libFun (fsLit "letS")    letSIdKey
1689 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1690 parSName    = libFun (fsLit "parS")    parSIdKey
1691
1692 -- data Dec = ...
1693 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1694     instanceDName, sigDName, forImpDName, familyDName, dataInstDName,
1695     newtypeInstDName, tySynInstDName :: Name
1696 funDName         = libFun (fsLit "funD")         funDIdKey
1697 valDName         = libFun (fsLit "valD")         valDIdKey
1698 dataDName        = libFun (fsLit "dataD")        dataDIdKey
1699 newtypeDName     = libFun (fsLit "newtypeD")     newtypeDIdKey
1700 tySynDName       = libFun (fsLit "tySynD")       tySynDIdKey
1701 classDName       = libFun (fsLit "classD")       classDIdKey
1702 instanceDName    = libFun (fsLit "instanceD")    instanceDIdKey
1703 sigDName         = libFun (fsLit "sigD")         sigDIdKey
1704 forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
1705 familyDName      = libFun (fsLit "familyD")      familyDIdKey
1706 dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
1707 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1708 tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
1709
1710 -- type Ctxt = ...
1711 cxtName :: Name
1712 cxtName = libFun (fsLit "cxt") cxtIdKey
1713
1714 -- data Strict = ...
1715 isStrictName, notStrictName :: Name
1716 isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
1717 notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
1718
1719 -- data Con = ...
1720 normalCName, recCName, infixCName, forallCName :: Name
1721 normalCName = libFun (fsLit "normalC") normalCIdKey
1722 recCName    = libFun (fsLit "recC")    recCIdKey
1723 infixCName  = libFun (fsLit "infixC")  infixCIdKey
1724 forallCName  = libFun (fsLit "forallC")  forallCIdKey
1725
1726 -- type StrictType = ...
1727 strictTypeName :: Name
1728 strictTypeName    = libFun  (fsLit "strictType")    strictTKey
1729
1730 -- type VarStrictType = ...
1731 varStrictTypeName :: Name
1732 varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
1733
1734 -- data Type = ...
1735 forallTName, varTName, conTName, tupleTName, arrowTName,
1736     listTName, appTName :: Name
1737 forallTName = libFun (fsLit "forallT") forallTIdKey
1738 varTName    = libFun (fsLit "varT")    varTIdKey
1739 conTName    = libFun (fsLit "conT")    conTIdKey
1740 tupleTName  = libFun (fsLit "tupleT") tupleTIdKey
1741 arrowTName  = libFun (fsLit "arrowT") arrowTIdKey
1742 listTName   = libFun (fsLit "listT")  listTIdKey
1743 appTName    = libFun (fsLit "appT")    appTIdKey
1744
1745 -- data Callconv = ...
1746 cCallName, stdCallName :: Name
1747 cCallName = libFun (fsLit "cCall") cCallIdKey
1748 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1749
1750 -- data Safety = ...
1751 unsafeName, safeName, threadsafeName :: Name
1752 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
1753 safeName       = libFun (fsLit "safe") safeIdKey
1754 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1755
1756 -- data FunDep = ...
1757 funDepName :: Name
1758 funDepName     = libFun (fsLit "funDep") funDepIdKey
1759
1760 -- data FamFlavour = ...
1761 typeFamName, dataFamName :: Name
1762 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1763 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1764
1765 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1766     decQTyConName, conQTyConName, strictTypeQTyConName,
1767     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1768     patQTyConName, fieldPatQTyConName :: Name
1769 matchQTyConName         = libTc (fsLit "MatchQ")        matchQTyConKey
1770 clauseQTyConName        = libTc (fsLit "ClauseQ")       clauseQTyConKey
1771 expQTyConName           = libTc (fsLit "ExpQ")          expQTyConKey
1772 stmtQTyConName          = libTc (fsLit "StmtQ")         stmtQTyConKey
1773 decQTyConName           = libTc (fsLit "DecQ")          decQTyConKey
1774 conQTyConName           = libTc (fsLit "ConQ")          conQTyConKey
1775 strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
1776 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1777 typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
1778 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
1779 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
1780 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
1781
1782 -- quasiquoting
1783 quoteExpName, quotePatName :: Name
1784 quoteExpName        = qqFun (fsLit "quoteExp") quoteExpKey
1785 quotePatName        = qqFun (fsLit "quotePat") quotePatKey
1786
1787 -- TyConUniques available: 100-129
1788 -- Check in PrelNames if you want to change this
1789
1790 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
1791     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
1792     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
1793     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
1794     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
1795     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey :: Unique
1796 expTyConKey             = mkPreludeTyConUnique 100
1797 matchTyConKey           = mkPreludeTyConUnique 101
1798 clauseTyConKey          = mkPreludeTyConUnique 102
1799 qTyConKey               = mkPreludeTyConUnique 103
1800 expQTyConKey            = mkPreludeTyConUnique 104
1801 decQTyConKey            = mkPreludeTyConUnique 105
1802 patTyConKey             = mkPreludeTyConUnique 106
1803 matchQTyConKey          = mkPreludeTyConUnique 107
1804 clauseQTyConKey         = mkPreludeTyConUnique 108
1805 stmtQTyConKey           = mkPreludeTyConUnique 109
1806 conQTyConKey            = mkPreludeTyConUnique 110
1807 typeQTyConKey           = mkPreludeTyConUnique 111
1808 typeTyConKey            = mkPreludeTyConUnique 112
1809 decTyConKey             = mkPreludeTyConUnique 113
1810 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
1811 strictTypeQTyConKey     = mkPreludeTyConUnique 115
1812 fieldExpTyConKey        = mkPreludeTyConUnique 116
1813 fieldPatTyConKey        = mkPreludeTyConUnique 117
1814 nameTyConKey            = mkPreludeTyConUnique 118
1815 patQTyConKey            = mkPreludeTyConUnique 119
1816 fieldPatQTyConKey       = mkPreludeTyConUnique 120
1817 fieldExpQTyConKey       = mkPreludeTyConUnique 121
1818 funDepTyConKey          = mkPreludeTyConUnique 122
1819
1820 -- IdUniques available: 200-399
1821 -- If you want to change this, make sure you check in PrelNames
1822
1823 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
1824     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
1825     mkNameLIdKey :: Unique
1826 returnQIdKey        = mkPreludeMiscIdUnique 200
1827 bindQIdKey          = mkPreludeMiscIdUnique 201
1828 sequenceQIdKey      = mkPreludeMiscIdUnique 202
1829 liftIdKey           = mkPreludeMiscIdUnique 203
1830 newNameIdKey         = mkPreludeMiscIdUnique 204
1831 mkNameIdKey          = mkPreludeMiscIdUnique 205
1832 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
1833 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
1834 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
1835 mkNameLIdKey         = mkPreludeMiscIdUnique 209
1836
1837
1838 -- data Lit = ...
1839 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
1840     floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
1841 charLIdKey        = mkPreludeMiscIdUnique 210
1842 stringLIdKey      = mkPreludeMiscIdUnique 211
1843 integerLIdKey     = mkPreludeMiscIdUnique 212
1844 intPrimLIdKey     = mkPreludeMiscIdUnique 213
1845 wordPrimLIdKey    = mkPreludeMiscIdUnique 214
1846 floatPrimLIdKey   = mkPreludeMiscIdUnique 215
1847 doublePrimLIdKey  = mkPreludeMiscIdUnique 216
1848 rationalLIdKey    = mkPreludeMiscIdUnique 217
1849
1850 -- data Pat = ...
1851 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey,
1852     asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
1853 litPIdKey         = mkPreludeMiscIdUnique 220
1854 varPIdKey         = mkPreludeMiscIdUnique 221
1855 tupPIdKey         = mkPreludeMiscIdUnique 222
1856 conPIdKey         = mkPreludeMiscIdUnique 223
1857 infixPIdKey       = mkPreludeMiscIdUnique 312
1858 tildePIdKey       = mkPreludeMiscIdUnique 224
1859 asPIdKey          = mkPreludeMiscIdUnique 225
1860 wildPIdKey        = mkPreludeMiscIdUnique 226
1861 recPIdKey         = mkPreludeMiscIdUnique 227
1862 listPIdKey        = mkPreludeMiscIdUnique 228
1863 sigPIdKey         = mkPreludeMiscIdUnique 229
1864
1865 -- type FieldPat = ...
1866 fieldPatIdKey :: Unique
1867 fieldPatIdKey       = mkPreludeMiscIdUnique 230
1868
1869 -- data Match = ...
1870 matchIdKey :: Unique
1871 matchIdKey          = mkPreludeMiscIdUnique 231
1872
1873 -- data Clause = ...
1874 clauseIdKey :: Unique
1875 clauseIdKey         = mkPreludeMiscIdUnique 232
1876
1877 -- data Exp = ...
1878 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
1879     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
1880     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
1881     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
1882     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
1883 varEIdKey         = mkPreludeMiscIdUnique 240
1884 conEIdKey         = mkPreludeMiscIdUnique 241
1885 litEIdKey         = mkPreludeMiscIdUnique 242
1886 appEIdKey         = mkPreludeMiscIdUnique 243
1887 infixEIdKey       = mkPreludeMiscIdUnique 244
1888 infixAppIdKey       = mkPreludeMiscIdUnique 245
1889 sectionLIdKey       = mkPreludeMiscIdUnique 246
1890 sectionRIdKey       = mkPreludeMiscIdUnique 247
1891 lamEIdKey         = mkPreludeMiscIdUnique 248
1892 tupEIdKey         = mkPreludeMiscIdUnique 249
1893 condEIdKey        = mkPreludeMiscIdUnique 250
1894 letEIdKey         = mkPreludeMiscIdUnique 251
1895 caseEIdKey        = mkPreludeMiscIdUnique 252
1896 doEIdKey          = mkPreludeMiscIdUnique 253
1897 compEIdKey        = mkPreludeMiscIdUnique 254
1898 fromEIdKey        = mkPreludeMiscIdUnique 255
1899 fromThenEIdKey    = mkPreludeMiscIdUnique 256
1900 fromToEIdKey      = mkPreludeMiscIdUnique 257
1901 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
1902 listEIdKey        = mkPreludeMiscIdUnique 259
1903 sigEIdKey         = mkPreludeMiscIdUnique 260
1904 recConEIdKey      = mkPreludeMiscIdUnique 261
1905 recUpdEIdKey      = mkPreludeMiscIdUnique 262
1906
1907 -- type FieldExp = ...
1908 fieldExpIdKey :: Unique
1909 fieldExpIdKey       = mkPreludeMiscIdUnique 265
1910
1911 -- data Body = ...
1912 guardedBIdKey, normalBIdKey :: Unique
1913 guardedBIdKey     = mkPreludeMiscIdUnique 266
1914 normalBIdKey      = mkPreludeMiscIdUnique 267
1915
1916 -- data Guard = ...
1917 normalGEIdKey, patGEIdKey :: Unique
1918 normalGEIdKey     = mkPreludeMiscIdUnique 310
1919 patGEIdKey        = mkPreludeMiscIdUnique 311
1920
1921 -- data Stmt = ...
1922 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
1923 bindSIdKey       = mkPreludeMiscIdUnique 268
1924 letSIdKey        = mkPreludeMiscIdUnique 269
1925 noBindSIdKey     = mkPreludeMiscIdUnique 270
1926 parSIdKey        = mkPreludeMiscIdUnique 271
1927
1928 -- data Dec = ...
1929 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
1930     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, familyDIdKey,
1931     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
1932 funDIdKey         = mkPreludeMiscIdUnique 272
1933 valDIdKey         = mkPreludeMiscIdUnique 273
1934 dataDIdKey        = mkPreludeMiscIdUnique 274
1935 newtypeDIdKey     = mkPreludeMiscIdUnique 275
1936 tySynDIdKey       = mkPreludeMiscIdUnique 276
1937 classDIdKey       = mkPreludeMiscIdUnique 277
1938 instanceDIdKey    = mkPreludeMiscIdUnique 278
1939 sigDIdKey         = mkPreludeMiscIdUnique 279
1940 forImpDIdKey      = mkPreludeMiscIdUnique 297
1941 familyDIdKey      = mkPreludeMiscIdUnique 340
1942 dataInstDIdKey    = mkPreludeMiscIdUnique 341
1943 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
1944 tySynInstDIdKey   = mkPreludeMiscIdUnique 343
1945
1946 -- type Cxt = ...
1947 cxtIdKey :: Unique
1948 cxtIdKey            = mkPreludeMiscIdUnique 280
1949
1950 -- data Strict = ...
1951 isStrictKey, notStrictKey :: Unique
1952 isStrictKey         = mkPreludeMiscIdUnique 281
1953 notStrictKey        = mkPreludeMiscIdUnique 282
1954
1955 -- data Con = ...
1956 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
1957 normalCIdKey      = mkPreludeMiscIdUnique 283
1958 recCIdKey         = mkPreludeMiscIdUnique 284
1959 infixCIdKey       = mkPreludeMiscIdUnique 285
1960 forallCIdKey      = mkPreludeMiscIdUnique 288
1961
1962 -- type StrictType = ...
1963 strictTKey :: Unique
1964 strictTKey        = mkPreludeMiscIdUnique 286
1965
1966 -- type VarStrictType = ...
1967 varStrictTKey :: Unique
1968 varStrictTKey     = mkPreludeMiscIdUnique 287
1969
1970 -- data Type = ...
1971 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
1972     listTIdKey, appTIdKey :: Unique
1973 forallTIdKey      = mkPreludeMiscIdUnique 290
1974 varTIdKey         = mkPreludeMiscIdUnique 291
1975 conTIdKey         = mkPreludeMiscIdUnique 292
1976 tupleTIdKey       = mkPreludeMiscIdUnique 294
1977 arrowTIdKey       = mkPreludeMiscIdUnique 295
1978 listTIdKey        = mkPreludeMiscIdUnique 296
1979 appTIdKey         = mkPreludeMiscIdUnique 293
1980
1981 -- data Callconv = ...
1982 cCallIdKey, stdCallIdKey :: Unique
1983 cCallIdKey      = mkPreludeMiscIdUnique 300
1984 stdCallIdKey    = mkPreludeMiscIdUnique 301
1985
1986 -- data Safety = ...
1987 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
1988 unsafeIdKey     = mkPreludeMiscIdUnique 305
1989 safeIdKey       = mkPreludeMiscIdUnique 306
1990 threadsafeIdKey = mkPreludeMiscIdUnique 307
1991
1992 -- data FunDep = ...
1993 funDepIdKey :: Unique
1994 funDepIdKey = mkPreludeMiscIdUnique 320
1995
1996 -- data FamFlavour = ...
1997 typeFamIdKey, dataFamIdKey :: Unique
1998 typeFamIdKey = mkPreludeMiscIdUnique 344
1999 dataFamIdKey = mkPreludeMiscIdUnique 345
2000
2001 -- quasiquoting
2002 quoteExpKey, quotePatKey :: Unique
2003 quoteExpKey = mkPreludeMiscIdUnique 321
2004 quotePatKey = mkPreludeMiscIdUnique 322
2005