compiler/deSugar/DsMeta.hs

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