compiler/deSugar/DsMeta.hs

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