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