compiler/deSugar/DsMeta.hs

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