compiler/deSugar/DsMeta.hs

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