compiler/deSugar/DsMeta.hs

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