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