compiler/deSugar/DsMeta.hs

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