compiler/deSugar/DsMeta.hs

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