compiler/deSugar/DsMeta.hs

   1 -----------------------------------------------------------------------------
   2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
   3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
   4 -- input HsExpr. We do this in the DsM monad, which supplies access to
   5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
   6 --
   7 -- It also defines a bunch of knownKeyNames, in the same way as is done
   8 -- in prelude/PrelNames.  It's much more convenient to do it here, becuase
   9 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
  10 -- a Royal Pain (triggers other recompilation).
  11 -----------------------------------------------------------------------------
  12
  13
  14 module DsMeta( dsBracket,
  15                templateHaskellNames, qTyConName, nameTyConName,
  16                liftName, expQTyConName, decQTyConName, typeQTyConName,
  17                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
  18                 ) where
  19
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-}   DsExpr ( dsExpr )
  23
  24 import MatchLit   ( dsLit )
  25 import DsUtils    ( mkListExpr, mkStringExpr, mkIntExpr )
  26 import DsMonad
  27
  28 import qualified Language.Haskell.TH as TH
  29
  30 import HsSyn
  31 import Class (FunDep)
  32 import PrelNames  ( rationalTyConName, integerTyConName, negateName )
  33 import OccName    ( isDataOcc, isTvOcc, occNameString )
  34 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
  35 -- we do this by removing varName from the import of OccName above, making
  36 -- a qualified instance of OccName and using OccNameAlias.varName where varName
  37 -- ws previously used in this file.
  38 import qualified OccName
  39
  40 import Module     ( Module, mkModule, moduleNameString, moduleName,
  41                     modulePackageId, mkModuleNameFS )
  42 import Id         ( Id, mkLocalId )
  43 import OccName    ( mkOccNameFS )
  44 import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule,
  45                     isExternalName, getSrcLoc )
  46 import NameEnv
  47 import Type       ( Type, mkTyConApp )
  48 import TcType     ( tcTyConAppArgs )
  49 import TyCon      ( tyConName )
  50 import TysWiredIn ( parrTyCon )
  51 import CoreSyn
  52 import CoreUtils  ( exprType )
  53 import SrcLoc     ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
  54 import PackageConfig ( thPackageId, packageIdString )
  55 import Unique     ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
  56 import BasicTypes ( isBoxed )
  57 import Outputable
  58 import Bag        ( bagToList, unionManyBags )
  59 import FastString ( unpackFS )
  60 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
  61
  62 import Maybe      ( catMaybes )
  63 import Monad ( zipWithM )
  64 import List ( sortBy )
  65
  66 -----------------------------------------------------------------------------
  67 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  68 -- Returns a CoreExpr of type TH.ExpQ
  69 -- The quoted thing is parameterised over Name, even though it has
  70 -- been type checked.  We don't want all those type decorations!
  71
  72 dsBracket brack splices
  73   = dsExtendMetaEnv new_bit (do_brack brack)
  74   where
  75     new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
  76
  77     do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
  78     do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
  79     do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
  80     do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
  81     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
  82
  83 {- -------------- Examples --------------------
  84
  85   [| \x -> x |]
  86 ====>
  87   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  88   lam (pvar x1) (var x1)
  89
  90
  91   [| \x -> $(f [| x |]) |]
  92 ====>
  93   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  94   lam (pvar x1) (f (var x1))
  95 -}
  96
  97
  98 -------------------------------------------------------
  99 --                      Declarations
 100 -------------------------------------------------------
 101
 102 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 103 repTopDs group
 104  = do { let { bndrs = map unLoc (groupBinders group) } ;
 105         ss <- mkGenSyms bndrs ;
 106
 107         -- Bind all the names mainly to avoid repeated use of explicit strings.
 108         -- Thus we get
 109         --      do { t :: String <- genSym "T" ;
 110         --           return (Data t [] ...more t's... }
 111         -- The other important reason is that the output must mention
 112         -- only "T", not "Foo:T" where Foo is the current module
 113
 114
 115         decls <- addBinds ss (do {
 116                         val_ds  <- rep_val_binds (hs_valds group) ;
 117                         tycl_ds <- mapM repTyClD (hs_tyclds group) ;
 118                         inst_ds <- mapM repInstD' (hs_instds group) ;
 119                         for_ds <- mapM repForD (hs_fords group) ;
 120                         -- more needed
 121                         return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
 122
 123         decl_ty <- lookupType decQTyConName ;
 124         let { core_list = coreList' decl_ty decls } ;
 125
 126         dec_ty <- lookupType decTyConName ;
 127         q_decs  <- repSequenceQ dec_ty core_list ;
 128
 129         wrapNongenSyms ss q_decs
 130         -- Do *not* gensym top-level binders
 131       }
 132
 133 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 134                         hs_fords = foreign_decls })
 135 -- Collect the binders of a Group
 136   = collectHsValBinders val_decls ++
 137     [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
 138     [n | L _ (ForeignImport n _ _) <- foreign_decls]
 139
 140
 141 {-      Note [Binders and occurrences]
 142         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 143 When we desugar [d| data T = MkT |]
 144 we want to get
 145         Data "T" [] [Con "MkT" []] []
 146 and *not*
 147         Data "Foo:T" [] [Con "Foo:MkT" []] []
 148 That is, the new data decl should fit into whatever new module it is
 149 asked to fit in.   We do *not* clone, though; no need for this:
 150         Data "T79" ....
 151
 152 But if we see this:
 153         data T = MkT
 154         foo = reifyDecl T
 155
 156 then we must desugar to
 157         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
 158
 159 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
 160 And we use lookupOcc, rather than lookupBinder
 161 in repTyClD and repC.
 162
 163 -}
 164
 165 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 166
 167 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
 168                     tcdLName = tc, tcdTyVars = tvs,
 169                     tcdCons = cons, tcdDerivs = mb_derivs }))
 170  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 171         dec <- addTyVarBinds tvs $ \bndrs -> do {
 172                cxt1    <- repLContext cxt ;
 173                cons1   <- mapM repC cons ;
 174                cons2   <- coreList conQTyConName cons1 ;
 175                derivs1 <- repDerivs mb_derivs ;
 176                bndrs1  <- coreList nameTyConName bndrs ;
 177                repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
 178         return $ Just (loc, dec) }
 179
 180 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
 181                     tcdLName = tc, tcdTyVars = tvs,
 182                     tcdCons = [con], tcdDerivs = mb_derivs }))
 183  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 184         dec <- addTyVarBinds tvs $ \bndrs -> do {
 185                cxt1   <- repLContext cxt ;
 186                con1   <- repC con ;
 187                derivs1 <- repDerivs mb_derivs ;
 188                bndrs1  <- coreList nameTyConName bndrs ;
 189                repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
 190         return $ Just (loc, dec) }
 191
 192 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 193  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 194         dec <- addTyVarBinds tvs $ \bndrs -> do {
 195                ty1     <- repLTy ty ;
 196                bndrs1  <- coreList nameTyConName bndrs ;
 197                repTySyn tc1 bndrs1 ty1 } ;
 198         return (Just (loc, dec)) }
 199
 200 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
 201                       tcdTyVars = tvs,
 202                       tcdFDs = fds,
 203                       tcdSigs = sigs, tcdMeths = meth_binds }))
 204  = do { cls1 <- lookupLOcc cls ;                -- See note [Binders and occurrences]
 205         dec  <- addTyVarBinds tvs $ \bndrs -> do {
 206                   cxt1   <- repLContext cxt ;
 207                   sigs1  <- rep_sigs sigs ;
 208                   binds1 <- rep_binds meth_binds ;
 209                   fds1 <- repLFunDeps fds;
 210                   decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
 211                   bndrs1 <- coreList nameTyConName bndrs ;
 212                   repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
 213         return $ Just (loc, dec) }
 214
 215 -- Un-handled cases
 216 repTyClD (L loc d) = putSrcSpanDs loc $
 217                      do { dsWarn (hang ds_msg 4 (ppr d))
 218                         ; return Nothing }
 219
 220 -- represent fundeps
 221 --
 222 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
 223 repLFunDeps fds = do fds' <- mapM repLFunDep fds
 224                      fdList <- coreList funDepTyConName fds'
 225                      return fdList
 226
 227 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
 228 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
 229                                ys' <- mapM lookupBinder ys
 230                                xs_list <- coreList nameTyConName xs'
 231                                ys_list <- coreList nameTyConName ys'
 232                                repFunDep xs_list ys_list
 233
 234 repInstD' (L loc (InstDecl ty binds _))         -- Ignore user pragmas for now
 235  = do   { i <- addTyVarBinds tvs $ \tv_bndrs ->
 236                 -- We must bring the type variables into scope, so their occurrences
 237                 -- don't fail,  even though the binders don't appear in the resulting
 238                 -- data structure
 239                 do {  cxt1 <- repContext cxt
 240                    ; inst_ty1 <- repPred (HsClassP cls tys)
 241                    ; ss <- mkGenSyms (collectHsBindBinders binds)
 242                    ; binds1 <- addBinds ss (rep_binds binds)
 243                    ; decls1 <- coreList decQTyConName binds1
 244                    ; decls2 <- wrapNongenSyms ss decls1
 245                    -- wrapNonGenSyms: do not clone the class op names!
 246                    -- They must be called 'op' etc, not 'op34'
 247                    ; repInst cxt1 inst_ty1 decls2 }
 248
 249         ; return (loc, i)}
 250  where
 251    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 252
 253 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 254 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
 255  = do MkC name' <- lookupLOcc name
 256       MkC typ' <- repLTy typ
 257       MkC cc' <- repCCallConv cc
 258       MkC s' <- repSafety s
 259       MkC str <- coreStringLit $ static
 260                               ++ unpackFS ch ++ " "
 261                               ++ unpackFS cn ++ " "
 262                               ++ conv_cimportspec cis
 263       dec <- rep2 forImpDName [cc', s', str, name', typ']
 264       return (loc, dec)
 265  where
 266     conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
 267     conv_cimportspec (CFunction DynamicTarget) = "dynamic"
 268     conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
 269     conv_cimportspec CWrapper = "wrapper"
 270     static = case cis of
 271                  CFunction (StaticTarget _) -> "static "
 272                  _ -> ""
 273
 274 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
 275 repCCallConv CCallConv = rep2 cCallName []
 276 repCCallConv StdCallConv = rep2 stdCallName []
 277
 278 repSafety :: Safety -> DsM (Core TH.Safety)
 279 repSafety PlayRisky = rep2 unsafeName []
 280 repSafety (PlaySafe False) = rep2 safeName []
 281 repSafety (PlaySafe True) = rep2 threadsafeName []
 282
 283 ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 284
 285 -------------------------------------------------------
 286 --                      Constructors
 287 -------------------------------------------------------
 288
 289 repC :: LConDecl Name -> DsM (Core TH.ConQ)
 290 repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
 291   = do { con1 <- lookupLOcc con ;               -- See note [Binders and occurrences]
 292          repConstr con1 details }
 293 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
 294   = do { addTyVarBinds tvs $ \bndrs -> do {
 295              c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
 296              ctxt' <- repContext ctxt;
 297              bndrs' <- coreList nameTyConName bndrs;
 298              rep2 forallCName [unC bndrs', unC ctxt', unC c']
 299          }
 300        }
 301 repC (L loc con_decl)           -- GADTs
 302   = putSrcSpanDs loc $
 303     do  { dsWarn (hang ds_msg 4 (ppr con_decl))
 304         ; return (panic "DsMeta:repC") }
 305
 306 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 307 repBangTy ty= do
 308   MkC s <- rep2 str []
 309   MkC t <- repLTy ty'
 310   rep2 strictTypeName [s, t]
 311   where
 312     (str, ty') = case ty of
 313                    L _ (HsBangTy _ ty) -> (isStrictName,  ty)
 314                    other               -> (notStrictName, ty)
 315
 316 -------------------------------------------------------
 317 --                      Deriving clause
 318 -------------------------------------------------------
 319
 320 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
 321 repDerivs Nothing = coreList nameTyConName []
 322 repDerivs (Just ctxt)
 323   = do { strs <- mapM rep_deriv ctxt ;
 324          coreList nameTyConName strs }
 325   where
 326     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
 327         -- Deriving clauses must have the simple H98 form
 328     rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
 329     rep_deriv other                              = panic "rep_deriv"
 330
 331
 332 -------------------------------------------------------
 333 --   Signatures in a class decl, or a group of bindings
 334 -------------------------------------------------------
 335
 336 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
 337 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
 338                    return $ de_loc $ sort_by_loc locs_cores
 339
 340 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
 341         -- We silently ignore ones we don't recognise
 342 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 343                      return (concat sigs1) }
 344
 345 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 346         -- Singleton => Ok
 347         -- Empty     => Too hard, signature ignored
 348 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
 349 rep_sig other                   = return []
 350
 351 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
 352 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
 353                        ty1 <- repLTy ty ;
 354                        sig <- repProto nm1 ty1 ;
 355                        return [(loc, sig)] }
 356
 357
 358 -------------------------------------------------------
 359 --                      Types
 360 -------------------------------------------------------
 361
 362 -- gensym a list of type variables and enter them into the meta environment;
 363 -- the computations passed as the second argument is executed in that extended
 364 -- meta environment and gets the *new* names on Core-level as an argument
 365 --
 366 addTyVarBinds :: [LHsTyVarBndr Name]             -- the binders to be added
 367               -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
 368               -> DsM (Core (TH.Q a))
 369 addTyVarBinds tvs m =
 370   do
 371     let names = map (hsTyVarName.unLoc) tvs
 372     freshNames <- mkGenSyms names
 373     term       <- addBinds freshNames $ do
 374                     bndrs <- mapM lookupBinder names
 375                     m bndrs
 376     wrapGenSyns freshNames term
 377
 378 -- represent a type context
 379 --
 380 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
 381 repLContext (L _ ctxt) = repContext ctxt
 382
 383 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 384 repContext ctxt = do
 385                     preds    <- mapM repLPred ctxt
 386                     predList <- coreList typeQTyConName preds
 387                     repCtxt predList
 388
 389 -- represent a type predicate
 390 --
 391 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
 392 repLPred (L _ p) = repPred p
 393
 394 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
 395 repPred (HsClassP cls tys) = do
 396                                tcon <- repTy (HsTyVar cls)
 397                                tys1 <- repLTys tys
 398                                repTapps tcon tys1
 399 repPred (HsIParam _ _)     =
 400   panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
 401
 402 -- yield the representation of a list of types
 403 --
 404 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 405 repLTys tys = mapM repLTy tys
 406
 407 -- represent a type
 408 --
 409 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 410 repLTy (L _ ty) = repTy ty
 411
 412 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 413 repTy (HsForAllTy _ tvs ctxt ty)  =
 414   addTyVarBinds tvs $ \bndrs -> do
 415     ctxt1  <- repLContext ctxt
 416     ty1    <- repLTy ty
 417     bndrs1 <- coreList nameTyConName bndrs
 418     repTForall bndrs1 ctxt1 ty1
 419
 420 repTy (HsTyVar n)
 421   | isTvOcc (nameOccName n)       = do
 422                                       tv1 <- lookupBinder n
 423                                       repTvar tv1
 424   | otherwise                     = do
 425                                       tc1 <- lookupOcc n
 426                                       repNamedTyCon tc1
 427 repTy (HsAppTy f a)               = do
 428                                       f1 <- repLTy f
 429                                       a1 <- repLTy a
 430                                       repTapp f1 a1
 431 repTy (HsFunTy f a)               = do
 432                                       f1   <- repLTy f
 433                                       a1   <- repLTy a
 434                                       tcon <- repArrowTyCon
 435                                       repTapps tcon [f1, a1]
 436 repTy (HsListTy t)                = do
 437                                       t1   <- repLTy t
 438                                       tcon <- repListTyCon
 439                                       repTapp tcon t1
 440 repTy (HsPArrTy t)                = do
 441                                       t1   <- repLTy t
 442                                       tcon <- repTy (HsTyVar (tyConName parrTyCon))
 443                                       repTapp tcon t1
 444 repTy (HsTupleTy tc tys)          = do
 445                                       tys1 <- repLTys tys
 446                                       tcon <- repTupleTyCon (length tys)
 447                                       repTapps tcon tys1
 448 repTy (HsOpTy ty1 n ty2)          = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 449                                            `nlHsAppTy` ty2)
 450 repTy (HsParTy t)                 = repLTy t
 451 repTy (HsNumTy i)                 =
 452   panic "DsMeta.repTy: Can't represent number types (for generics)"
 453 repTy (HsPredTy pred)             = repPred pred
 454 repTy (HsKindSig ty kind)         =
 455   panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
 456
 457
 458 -----------------------------------------------------------------------------
 459 --              Expressions
 460 -----------------------------------------------------------------------------
 461
 462 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
 463 repLEs es = do { es'  <- mapM repLE es ;
 464                  coreList expQTyConName es' }
 465
 466 -- FIXME: some of these panics should be converted into proper error messages
 467 --        unless we can make sure that constructs, which are plainly not
 468 --        supported in TH already lead to error messages at an earlier stage
 469 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
 470 repLE (L _ e) = repE e
 471
 472 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 473 repE (HsVar x)            =
 474   do { mb_val <- dsLookupMetaEnv x
 475      ; case mb_val of
 476         Nothing          -> do { str <- globalVar x
 477                                ; repVarOrCon x str }
 478         Just (Bound y)   -> repVarOrCon x (coreVar y)
 479         Just (Splice e)  -> do { e' <- dsExpr e
 480                                ; return (MkC e') } }
 481 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
 482
 483         -- Remember, we're desugaring renamer output here, so
 484         -- HsOverlit can definitely occur
 485 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 486 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 487 repE (HsLam (MatchGroup [m] _)) = repLambda m
 488 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 489
 490 repE (OpApp e1 op fix e2) =
 491   do { arg1 <- repLE e1;
 492        arg2 <- repLE e2;
 493        the_op <- repLE op ;
 494        repInfixApp arg1 the_op arg2 }
 495 repE (NegApp x nm)        = do
 496                               a         <- repLE x
 497                               negateVar <- lookupOcc negateName >>= repVar
 498                               negateVar `repApp` a
 499 repE (HsPar x)            = repLE x
 500 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 501 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 502 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 503                                        ; ms2 <- mapM repMatchTup ms
 504                                        ; repCaseE arg (nonEmptyCoreList ms2) }
 505 repE (HsIf x y z)         = do
 506                               a <- repLE x
 507                               b <- repLE y
 508                               c <- repLE z
 509                               repCond a b c
 510 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 511                                ; e2 <- addBinds ss (repLE e)
 512                                ; z <- repLetE ds e2
 513                                ; wrapGenSyns ss z }
 514 -- FIXME: I haven't got the types here right yet
 515 repE (HsDo DoExpr sts body ty)
 516  = do { (ss,zs) <- repLSts sts;
 517         body'   <- addBinds ss $ repLE body;
 518         ret     <- repNoBindSt body';
 519         e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
 520         wrapGenSyns ss e }
 521 repE (HsDo ListComp sts body ty)
 522  = do { (ss,zs) <- repLSts sts;
 523         body'   <- addBinds ss $ repLE body;
 524         ret     <- repNoBindSt body';
 525         e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
 526         wrapGenSyns ss e }
 527 repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 528 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
 529 repE (ExplicitPArr ty es) =
 530   panic "DsMeta.repE: No explicit parallel arrays yet"
 531 repE (ExplicitTuple es boxed)
 532   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
 533   | otherwise             = panic "DsMeta.repE: Can't represent unboxed tuples"
 534 repE (RecordCon c _ flds)
 535  = do { x <- lookupLOcc c;
 536         fs <- repFields flds;
 537         repRecCon x fs }
 538 repE (RecordUpd e flds _ _)
 539  = do { x <- repLE e;
 540         fs <- repFields flds;
 541         repRecUpd x fs }
 542
 543 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
 544 repE (ArithSeq _ aseq) =
 545   case aseq of
 546     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 547     FromThen e1 e2      -> do
 548                              ds1 <- repLE e1
 549                              ds2 <- repLE e2
 550                              repFromThen ds1 ds2
 551     FromTo   e1 e2      -> do
 552                              ds1 <- repLE e1
 553                              ds2 <- repLE e2
 554                              repFromTo ds1 ds2
 555     FromThenTo e1 e2 e3 -> do
 556                              ds1 <- repLE e1
 557                              ds2 <- repLE e2
 558                              ds3 <- repLE e3
 559                              repFromThenTo ds1 ds2 ds3
 560 repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
 561 repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
 562 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 563 repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
 564 repE (HsSpliceE (HsSplice n _))
 565   = do { mb_val <- dsLookupMetaEnv n
 566        ; case mb_val of
 567                  Just (Splice e) -> do { e' <- dsExpr e
 568                                        ; return (MkC e') }
 569                  other       -> pprPanic "HsSplice" (ppr n) }
 570
 571 repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
 572
 573 -----------------------------------------------------------------------------
 574 -- Building representations of auxillary structures like Match, Clause, Stmt,
 575
 576 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
 577 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
 578   do { ss1 <- mkGenSyms (collectPatBinders p)
 579      ; addBinds ss1 $ do {
 580      ; p1 <- repLP p
 581      ; (ss2,ds) <- repBinds wheres
 582      ; addBinds ss2 $ do {
 583      ; gs    <- repGuards guards
 584      ; match <- repMatch p1 gs ds
 585      ; wrapGenSyns (ss1++ss2) match }}}
 586
 587 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
 588 repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
 589   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 590      ; addBinds ss1 $ do {
 591        ps1 <- repLPs ps
 592      ; (ss2,ds) <- repBinds wheres
 593      ; addBinds ss2 $ do {
 594        gs <- repGuards guards
 595      ; clause <- repClause ps1 gs ds
 596      ; wrapGenSyns (ss1++ss2) clause }}}
 597
 598 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 599 repGuards [L _ (GRHS [] e)]
 600   = do {a <- repLE e; repNormal a }
 601 repGuards other
 602   = do { zs <- mapM process other;
 603      let {(xs, ys) = unzip zs};
 604          gd <- repGuarded (nonEmptyCoreList ys);
 605      wrapGenSyns (concat xs) gd }
 606   where
 607     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
 608     process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
 609            = do { x <- repLNormalGE e1 e2;
 610                   return ([], x) }
 611     process (L _ (GRHS ss rhs))
 612            = do (gs, ss') <- repLSts ss
 613                 rhs' <- addBinds gs $ repLE rhs
 614                 g <- repPatGE (nonEmptyCoreList ss') rhs'
 615                 return (gs, g)
 616
 617 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
 618 repFields flds = do
 619         fnames <- mapM lookupLOcc (map fst flds)
 620         es <- mapM repLE (map snd flds)
 621         fs <- zipWithM repFieldExp fnames es
 622         coreList fieldExpQTyConName fs
 623
 624
 625 -----------------------------------------------------------------------------
 626 -- Representing Stmt's is tricky, especially if bound variables
 627 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 628 -- First gensym new names for every variable in any of the patterns.
 629 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 630 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 631 -- and we could reuse the original names (x and x).
 632 --
 633 -- do { x'1 <- gensym "x"
 634 --    ; x'2 <- gensym "x"
 635 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 636 --          , BindSt (pvar x'2) [| f x |]
 637 --          , NoBindSt [| g x |]
 638 --          ]
 639 --    }
 640
 641 -- The strategy is to translate a whole list of do-bindings by building a
 642 -- bigger environment, and a bigger set of meta bindings
 643 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 644 -- of the expressions within the Do
 645
 646 -----------------------------------------------------------------------------
 647 -- The helper function repSts computes the translation of each sub expression
 648 -- and a bunch of prefix bindings denoting the dynamic renaming.
 649
 650 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 651 repLSts stmts = repSts (map unLoc stmts)
 652
 653 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 654 repSts (BindStmt p e _ _ : ss) =
 655    do { e2 <- repLE e
 656       ; ss1 <- mkGenSyms (collectPatBinders p)
 657       ; addBinds ss1 $ do {
 658       ; p1 <- repLP p;
 659       ; (ss2,zs) <- repSts ss
 660       ; z <- repBindSt p1 e2
 661       ; return (ss1++ss2, z : zs) }}
 662 repSts (LetStmt bs : ss) =
 663    do { (ss1,ds) <- repBinds bs
 664       ; z <- repLetSt ds
 665       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 666       ; return (ss1++ss2, z : zs) }
 667 repSts (ExprStmt e _ _ : ss) =
 668    do { e2 <- repLE e
 669       ; z <- repNoBindSt e2
 670       ; (ss2,zs) <- repSts ss
 671       ; return (ss2, z : zs) }
 672 repSts [] = return ([],[])
 673 repSts other = panic "Exotic Stmt in meta brackets"
 674
 675
 676 -----------------------------------------------------------
 677 --                      Bindings
 678 -----------------------------------------------------------
 679
 680 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 681 repBinds EmptyLocalBinds
 682   = do  { core_list <- coreList decQTyConName []
 683         ; return ([], core_list) }
 684
 685 repBinds (HsIPBinds _)
 686   = panic "DsMeta:repBinds: can't do implicit parameters"
 687
 688 repBinds (HsValBinds decs)
 689  = do   { let { bndrs = map unLoc (collectHsValBinders decs) }
 690                 -- No need to worrry about detailed scopes within
 691                 -- the binding group, because we are talking Names
 692                 -- here, so we can safely treat it as a mutually
 693                 -- recursive group
 694         ; ss        <- mkGenSyms bndrs
 695         ; prs       <- addBinds ss (rep_val_binds decs)
 696         ; core_list <- coreList decQTyConName
 697                                 (de_loc (sort_by_loc prs))
 698         ; return (ss, core_list) }
 699
 700 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 701 -- Assumes: all the binders of the binding are alrady in the meta-env
 702 rep_val_binds (ValBindsOut binds sigs)
 703  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
 704       ; core2 <- rep_sigs' sigs
 705       ; return (core1 ++ core2) }
 706
 707 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 708 rep_binds binds = do { binds_w_locs <- rep_binds' binds
 709                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 710
 711 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 712 rep_binds' binds = mapM rep_bind (bagToList binds)
 713
 714 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 715 -- Assumes: all the binders of the binding are alrady in the meta-env
 716
 717 -- Note GHC treats declarations of a variable (not a pattern)
 718 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 719 -- with an empty list of patterns
 720 rep_bind (L loc (FunBind { fun_id = fn,
 721                            fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
 722  = do { (ss,wherecore) <- repBinds wheres
 723         ; guardcore <- addBinds ss (repGuards guards)
 724         ; fn'  <- lookupLBinder fn
 725         ; p    <- repPvar fn'
 726         ; ans  <- repVal p guardcore wherecore
 727         ; ans' <- wrapGenSyns ss ans
 728         ; return (loc, ans') }
 729
 730 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 731  =   do { ms1 <- mapM repClauseTup ms
 732         ; fn' <- lookupLBinder fn
 733         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 734         ; return (loc, ans) }
 735
 736 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 737  =   do { patcore <- repLP pat
 738         ; (ss,wherecore) <- repBinds wheres
 739         ; guardcore <- addBinds ss (repGuards guards)
 740         ; ans  <- repVal patcore guardcore wherecore
 741         ; ans' <- wrapGenSyns ss ans
 742         ; return (loc, ans') }
 743
 744 rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
 745  =   do { v' <- lookupBinder v
 746         ; e2 <- repLE e
 747         ; x <- repNormal e2
 748         ; patcore <- repPvar v'
 749         ; empty_decls <- coreList decQTyConName []
 750         ; ans <- repVal patcore x empty_decls
 751         ; return (srcLocSpan (getSrcLoc v), ans) }
 752
 753 -----------------------------------------------------------------------------
 754 -- Since everything in a Bind is mutually recursive we need rename all
 755 -- all the variables simultaneously. For example:
 756 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 757 -- do { f'1 <- gensym "f"
 758 --    ; g'2 <- gensym "g"
 759 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 760 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 761 --      ]}
 762 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 763 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 764 -- together. As we do this we collect GenSymBinds's which represent the renamed
 765 -- variables bound by the Bindings. In order not to lose track of these
 766 -- representations we build a shadow datatype MB with the same structure as
 767 -- MonoBinds, but which has slots for the representations
 768
 769
 770 -----------------------------------------------------------------------------
 771 -- GHC allows a more general form of lambda abstraction than specified
 772 -- by Haskell 98. In particular it allows guarded lambda's like :
 773 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 774 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 775 -- (\ p1 .. pn -> exp) by causing an error.
 776
 777 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
 778 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 779  = do { let bndrs = collectPatsBinders ps ;
 780       ; ss  <- mkGenSyms bndrs
 781       ; lam <- addBinds ss (
 782                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 783       ; wrapGenSyns ss lam }
 784
 785 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 786
 787
 788 -----------------------------------------------------------------------------
 789 --                      Patterns
 790 -- repP deals with patterns.  It assumes that we have already
 791 -- walked over the pattern(s) once to collect the binders, and
 792 -- have extended the environment.  So every pattern-bound
 793 -- variable should already appear in the environment.
 794
 795 -- Process a list of patterns
 796 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
 797 repLPs ps = do { ps' <- mapM repLP ps ;
 798                  coreList patQTyConName ps' }
 799
 800 repLP :: LPat Name -> DsM (Core TH.PatQ)
 801 repLP (L _ p) = repP p
 802
 803 repP :: Pat Name -> DsM (Core TH.PatQ)
 804 repP (WildPat _)       = repPwild
 805 repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
 806 repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
 807 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
 808 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
 809 repP (ParPat p)        = repLP p
 810 repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
 811 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 812 repP (ConPatIn dc details)
 813  = do { con_str <- lookupLOcc dc
 814       ; case details of
 815          PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
 816          RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
 817                             ; ps <- sequence $ map repLP (map snd pairs)
 818                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
 819                             ; fps' <- coreList fieldPatQTyConName fps
 820                             ; repPrec con_str fps' }
 821          InfixCon p1 p2 -> do { p1' <- repLP p1;
 822                                 p2' <- repLP p2;
 823                                 repPinfix p1' con_str p2' }
 824    }
 825 repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
 826 repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
 827 repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 828 repP other = panic "Exotic pattern inside meta brackets"
 829
 830 ----------------------------------------------------------
 831 -- Declaration ordering helpers
 832
 833 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
 834 sort_by_loc xs = sortBy comp xs
 835     where comp x y = compare (fst x) (fst y)
 836
 837 de_loc :: [(a, b)] -> [b]
 838 de_loc = map snd
 839
 840 ----------------------------------------------------------
 841 --      The meta-environment
 842
 843 -- A name/identifier association for fresh names of locally bound entities
 844 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 845                                 -- I.e.         (x, x_id) means
 846                                 --      let x_id = gensym "x" in ...
 847
 848 -- Generate a fresh name for a locally bound entity
 849
 850 mkGenSyms :: [Name] -> DsM [GenSymBind]
 851 -- We can use the existing name.  For example:
 852 --      [| \x_77 -> x_77 + x_77 |]
 853 -- desugars to
 854 --      do { x_77 <- genSym "x"; .... }
 855 -- We use the same x_77 in the desugared program, but with the type Bndr
 856 -- instead of Int
 857 --
 858 -- We do make it an Internal name, though (hence localiseName)
 859 --
 860 -- Nevertheless, it's monadic because we have to generate nameTy
 861 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
 862                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
 863
 864
 865 addBinds :: [GenSymBind] -> DsM a -> DsM a
 866 -- Add a list of fresh names for locally bound entities to the
 867 -- meta environment (which is part of the state carried around
 868 -- by the desugarer monad)
 869 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 870
 871 -- Look up a locally bound name
 872 --
 873 lookupLBinder :: Located Name -> DsM (Core TH.Name)
 874 lookupLBinder (L _ n) = lookupBinder n
 875
 876 lookupBinder :: Name -> DsM (Core TH.Name)
 877 lookupBinder n
 878   = do { mb_val <- dsLookupMetaEnv n;
 879          case mb_val of
 880             Just (Bound x) -> return (coreVar x)
 881             other          -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
 882
 883 -- Look up a name that is either locally bound or a global name
 884 --
 885 --  * If it is a global name, generate the "original name" representation (ie,
 886 --   the <module>:<name> form) for the associated entity
 887 --
 888 lookupLOcc :: Located Name -> DsM (Core TH.Name)
 889 -- Lookup an occurrence; it can't be a splice.
 890 -- Use the in-scope bindings if they exist
 891 lookupLOcc (L _ n) = lookupOcc n
 892
 893 lookupOcc :: Name -> DsM (Core TH.Name)
 894 lookupOcc n
 895   = do {  mb_val <- dsLookupMetaEnv n ;
 896           case mb_val of
 897                 Nothing         -> globalVar n
 898                 Just (Bound x)  -> return (coreVar x)
 899                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
 900     }
 901
 902 globalVar :: Name -> DsM (Core TH.Name)
 903 -- Not bound by the meta-env
 904 -- Could be top-level; or could be local
 905 --      f x = $(g [| x |])
 906 -- Here the x will be local
 907 globalVar name
 908   | isExternalName name
 909   = do  { MkC mod <- coreStringLit name_mod
 910         ; MkC pkg <- coreStringLit name_pkg
 911         ; MkC occ <- occNameLit name
 912         ; rep2 mk_varg [pkg,mod,occ] }
 913   | otherwise
 914   = do  { MkC occ <- occNameLit name
 915         ; MkC uni <- coreIntLit (getKey (getUnique name))
 916         ; rep2 mkNameLName [occ,uni] }
 917   where
 918       mod = nameModule name
 919       name_mod = moduleNameString (moduleName mod)
 920       name_pkg = packageIdString (modulePackageId mod)
 921       name_occ = nameOccName name
 922       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
 923               | OccName.isVarOcc  name_occ = mkNameG_vName
 924               | OccName.isTcOcc   name_occ = mkNameG_tcName
 925               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
 926
 927 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
 928            -> DsM Type  -- The type
 929 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 930                           return (mkTyConApp tc []) }
 931
 932 wrapGenSyns :: [GenSymBind]
 933             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
 934 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
 935 --      --> bindQ (gensym nm1) (\ id1 ->
 936 --          bindQ (gensym nm2 (\ id2 ->
 937 --          y))
 938
 939 wrapGenSyns binds body@(MkC b)
 940   = do  { var_ty <- lookupType nameTyConName
 941         ; go var_ty binds }
 942   where
 943     [elt_ty] = tcTyConAppArgs (exprType b)
 944         -- b :: Q a, so we can get the type 'a' by looking at the
 945         -- argument type. NB: this relies on Q being a data/newtype,
 946         -- not a type synonym
 947
 948     go var_ty [] = return body
 949     go var_ty ((name,id) : binds)
 950       = do { MkC body'  <- go var_ty binds
 951            ; lit_str    <- occNameLit name
 952            ; gensym_app <- repGensym lit_str
 953            ; repBindQ var_ty elt_ty
 954                       gensym_app (MkC (Lam id body')) }
 955
 956 -- Just like wrapGenSym, but don't actually do the gensym
 957 -- Instead use the existing name:
 958 --      let x = "x" in ...
 959 -- Only used for [Decl], and for the class ops in class
 960 -- and instance decls
 961 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
 962 wrapNongenSyms binds (MkC body)
 963   = do { binds' <- mapM do_one binds ;
 964          return (MkC (mkLets binds' body)) }
 965   where
 966     do_one (name,id)
 967         = do { MkC lit_str <- occNameLit name
 968              ; MkC var <- rep2 mkNameName [lit_str]
 969              ; return (NonRec id var) }
 970
 971 occNameLit :: Name -> DsM (Core String)
 972 occNameLit n = coreStringLit (occNameString (nameOccName n))
 973
 974
 975 -- %*********************************************************************
 976 -- %*                                                                   *
 977 --              Constructing code
 978 -- %*                                                                   *
 979 -- %*********************************************************************
 980
 981 -----------------------------------------------------------------------------
 982 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 983 -- we invent a new datatype which uses phantom types.
 984
 985 newtype Core a = MkC CoreExpr
 986 unC (MkC x) = x
 987
 988 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 989 rep2 n xs = do { id <- dsLookupGlobalId n
 990                ; return (MkC (foldl App (Var id) xs)) }
 991
 992 -- Then we make "repConstructors" which use the phantom types for each of the
 993 -- smart constructors of the Meta.Meta datatypes.
 994
 995
 996 -- %*********************************************************************
 997 -- %*                                                                   *
 998 --              The 'smart constructors'
 999 -- %*                                                                   *
1000 -- %*********************************************************************
1001
1002 --------------- Patterns -----------------
1003 repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
1004 repPlit (MkC l) = rep2 litPName [l]
1005
1006 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1007 repPvar (MkC s) = rep2 varPName [s]
1008
1009 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1010 repPtup (MkC ps) = rep2 tupPName [ps]
1011
1012 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1013 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1014
1015 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1016 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1017
1018 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1019 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1020
1021 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1022 repPtilde (MkC p) = rep2 tildePName [p]
1023
1024 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1025 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1026
1027 repPwild  :: DsM (Core TH.PatQ)
1028 repPwild = rep2 wildPName []
1029
1030 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1031 repPlist (MkC ps) = rep2 listPName [ps]
1032
1033 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1034 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1035
1036 --------------- Expressions -----------------
1037 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1038 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1039                    | otherwise                  = repVar str
1040
1041 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1042 repVar (MkC s) = rep2 varEName [s]
1043
1044 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1045 repCon (MkC s) = rep2 conEName [s]
1046
1047 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1048 repLit (MkC c) = rep2 litEName [c]
1049
1050 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1051 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1052
1053 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1054 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1055
1056 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1057 repTup (MkC es) = rep2 tupEName [es]
1058
1059 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1060 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
1061
1062 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1063 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1064
1065 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1066 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1067
1068 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1069 repDoE (MkC ss) = rep2 doEName [ss]
1070
1071 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1072 repComp (MkC ss) = rep2 compEName [ss]
1073
1074 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1075 repListExp (MkC es) = rep2 listEName [es]
1076
1077 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1078 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1079
1080 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1081 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1082
1083 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1084 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1085
1086 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1087 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1088
1089 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1090 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1091
1092 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1093 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1094
1095 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1096 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1097
1098 ------------ Right hand sides (guarded expressions) ----
1099 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1100 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1101
1102 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1103 repNormal (MkC e) = rep2 normalBName [e]
1104
1105 ------------ Guards ----
1106 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1107 repLNormalGE g e = do g' <- repLE g
1108                       e' <- repLE e
1109                       repNormalGE g' e'
1110
1111 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1112 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1113
1114 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1115 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1116
1117 ------------- Stmts -------------------
1118 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1119 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1120
1121 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1122 repLetSt (MkC ds) = rep2 letSName [ds]
1123
1124 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1125 repNoBindSt (MkC e) = rep2 noBindSName [e]
1126
1127 -------------- Range (Arithmetic sequences) -----------
1128 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1129 repFrom (MkC x) = rep2 fromEName [x]
1130
1131 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1132 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1133
1134 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1135 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1136
1137 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1138 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1139
1140 ------------ Match and Clause Tuples -----------
1141 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1142 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1143
1144 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1145 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1146
1147 -------------- Dec -----------------------------
1148 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1149 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1150
1151 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1152 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1153
1154 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1155 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1156     = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1157
1158 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1159 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1160     = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1161
1162 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1163 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1164
1165 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1166 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1167
1168 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1169 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1170
1171 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1172 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1173
1174 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1175 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1176
1177 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1178 repCtxt (MkC tys) = rep2 cxtName [tys]
1179
1180 repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
1181           -> DsM (Core TH.ConQ)
1182 repConstr con (PrefixCon ps)
1183     = do arg_tys  <- mapM repBangTy ps
1184          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1185          rep2 normalCName [unC con, unC arg_tys1]
1186 repConstr con (RecCon ips)
1187     = do arg_vs   <- mapM lookupLOcc (map fst ips)
1188          arg_tys  <- mapM repBangTy (map snd ips)
1189          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1190                               arg_vs arg_tys
1191          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1192          rep2 recCName [unC con, unC arg_vtys']
1193 repConstr con (InfixCon st1 st2)
1194     = do arg1 <- repBangTy st1
1195          arg2 <- repBangTy st2
1196          rep2 infixCName [unC arg1, unC con, unC arg2]
1197
1198 ------------ Types -------------------
1199
1200 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1201 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1202     = rep2 forallTName [tvars, ctxt, ty]
1203
1204 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1205 repTvar (MkC s) = rep2 varTName [s]
1206
1207 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1208 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1209
1210 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1211 repTapps f []     = return f
1212 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1213
1214 --------- Type constructors --------------
1215
1216 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1217 repNamedTyCon (MkC s) = rep2 conTName [s]
1218
1219 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1220 -- Note: not Core Int; it's easier to be direct here
1221 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1222
1223 repArrowTyCon :: DsM (Core TH.TypeQ)
1224 repArrowTyCon = rep2 arrowTName []
1225
1226 repListTyCon :: DsM (Core TH.TypeQ)
1227 repListTyCon = rep2 listTName []
1228
1229
1230 ----------------------------------------------------------
1231 --              Literals
1232
1233 repLiteral :: HsLit -> DsM (Core TH.Lit)
1234 repLiteral lit
1235   = do lit' <- case lit of
1236                    HsIntPrim i    -> mk_integer i
1237                    HsInt i        -> mk_integer i
1238                    HsFloatPrim r  -> mk_rational r
1239                    HsDoublePrim r -> mk_rational r
1240                    _ -> return lit
1241        lit_expr <- dsLit lit'
1242        rep2 lit_name [lit_expr]
1243   where
1244     lit_name = case lit of
1245                  HsInteger _ _  -> integerLName
1246                  HsInt     _    -> integerLName
1247                  HsIntPrim _    -> intPrimLName
1248                  HsFloatPrim _  -> floatPrimLName
1249                  HsDoublePrim _ -> doublePrimLName
1250                  HsChar _       -> charLName
1251                  HsString _     -> stringLName
1252                  HsRat _ _      -> rationalLName
1253                  other          -> uh_oh
1254     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1255                     (ppr lit)
1256
1257 mk_integer  i = do integer_ty <- lookupType integerTyConName
1258                    return $ HsInteger i integer_ty
1259 mk_rational r = do rat_ty <- lookupType rationalTyConName
1260                    return $ HsRat r rat_ty
1261
1262 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1263 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
1264 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1265         -- The type Rational will be in the environment, becuase
1266         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1267         -- and rationalL is sucked in when any TH stuff is used
1268
1269 --------------- Miscellaneous -------------------
1270
1271 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1272 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1273
1274 repBindQ :: Type -> Type        -- a and b
1275          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1276 repBindQ ty_a ty_b (MkC x) (MkC y)
1277   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1278
1279 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1280 repSequenceQ ty_a (MkC list)
1281   = rep2 sequenceQName [Type ty_a, list]
1282
1283 ------------ Lists and Tuples -------------------
1284 -- turn a list of patterns into a single pattern matching a list
1285
1286 coreList :: Name        -- Of the TyCon of the element type
1287          -> [Core a] -> DsM (Core [a])
1288 coreList tc_name es
1289   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1290
1291 coreList' :: Type       -- The element type
1292           -> [Core a] -> Core [a]
1293 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1294
1295 nonEmptyCoreList :: [Core a] -> Core [a]
1296   -- The list must be non-empty so we can get the element type
1297   -- Otherwise use coreList
1298 nonEmptyCoreList []           = panic "coreList: empty argument"
1299 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1300
1301 coreStringLit :: String -> DsM (Core String)
1302 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1303
1304 coreIntLit :: Int -> DsM (Core Int)
1305 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1306
1307 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1308 coreVar id = MkC (Var id)
1309
1310
1311
1312 -- %************************************************************************
1313 -- %*                                                                   *
1314 --              The known-key names for Template Haskell
1315 -- %*                                                                   *
1316 -- %************************************************************************
1317
1318 -- To add a name, do three things
1319 --
1320 --  1) Allocate a key
1321 --  2) Make a "Name"
1322 --  3) Add the name to knownKeyNames
1323
1324 templateHaskellNames :: [Name]
1325 -- The names that are implicitly mentioned by ``bracket''
1326 -- Should stay in sync with the import list of DsMeta
1327
1328 templateHaskellNames = [
1329     returnQName, bindQName, sequenceQName, newNameName, liftName,
1330     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1331
1332     -- Lit
1333     charLName, stringLName, integerLName, intPrimLName,
1334     floatPrimLName, doublePrimLName, rationalLName,
1335     -- Pat
1336     litPName, varPName, tupPName, conPName, tildePName, infixPName,
1337     asPName, wildPName, recPName, listPName, sigPName,
1338     -- FieldPat
1339     fieldPatName,
1340     -- Match
1341     matchName,
1342     -- Clause
1343     clauseName,
1344     -- Exp
1345     varEName, conEName, litEName, appEName, infixEName,
1346     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1347     condEName, letEName, caseEName, doEName, compEName,
1348     fromEName, fromThenEName, fromToEName, fromThenToEName,
1349     listEName, sigEName, recConEName, recUpdEName,
1350     -- FieldExp
1351     fieldExpName,
1352     -- Body
1353     guardedBName, normalBName,
1354     -- Guard
1355     normalGEName, patGEName,
1356     -- Stmt
1357     bindSName, letSName, noBindSName, parSName,
1358     -- Dec
1359     funDName, valDName, dataDName, newtypeDName, tySynDName,
1360     classDName, instanceDName, sigDName, forImpDName,
1361     -- Cxt
1362     cxtName,
1363     -- Strict
1364     isStrictName, notStrictName,
1365     -- Con
1366     normalCName, recCName, infixCName, forallCName,
1367     -- StrictType
1368     strictTypeName,
1369     -- VarStrictType
1370     varStrictTypeName,
1371     -- Type
1372     forallTName, varTName, conTName, appTName,
1373     tupleTName, arrowTName, listTName,
1374     -- Callconv
1375     cCallName, stdCallName,
1376     -- Safety
1377     unsafeName,
1378     safeName,
1379     threadsafeName,
1380     -- FunDep
1381     funDepName,
1382
1383     -- And the tycons
1384     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1385     clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1386     decQTyConName, conQTyConName, strictTypeQTyConName,
1387     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1388     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1389     fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
1390
1391 thSyn :: Module
1392 thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax")
1393 thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
1394
1395 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1396
1397 mk_known_key_name mod space str uniq
1398   = mkExternalName uniq mod (mkOccNameFS space str)
1399                    Nothing noSrcLoc
1400
1401 libFun = mk_known_key_name thLib OccName.varName
1402 libTc  = mk_known_key_name thLib OccName.tcName
1403 thFun  = mk_known_key_name thSyn OccName.varName
1404 thTc   = mk_known_key_name thSyn OccName.tcName
1405
1406 -------------------- TH.Syntax -----------------------
1407 qTyConName        = thTc FSLIT("Q")            qTyConKey
1408 nameTyConName     = thTc FSLIT("Name")         nameTyConKey
1409 fieldExpTyConName = thTc FSLIT("FieldExp")     fieldExpTyConKey
1410 patTyConName      = thTc FSLIT("Pat")          patTyConKey
1411 fieldPatTyConName = thTc FSLIT("FieldPat")     fieldPatTyConKey
1412 expTyConName      = thTc FSLIT("Exp")          expTyConKey
1413 decTyConName      = thTc FSLIT("Dec")          decTyConKey
1414 typeTyConName     = thTc FSLIT("Type")         typeTyConKey
1415 matchTyConName    = thTc FSLIT("Match")        matchTyConKey
1416 clauseTyConName   = thTc FSLIT("Clause")       clauseTyConKey
1417 funDepTyConName   = thTc FSLIT("FunDep")       funDepTyConKey
1418
1419 returnQName   = thFun FSLIT("returnQ")   returnQIdKey
1420 bindQName     = thFun FSLIT("bindQ")     bindQIdKey
1421 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1422 newNameName    = thFun FSLIT("newName")   newNameIdKey
1423 liftName      = thFun FSLIT("lift")      liftIdKey
1424 mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
1425 mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
1426 mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
1427 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1428 mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey
1429
1430
1431 -------------------- TH.Lib -----------------------
1432 -- data Lit = ...
1433 charLName       = libFun FSLIT("charL")       charLIdKey
1434 stringLName     = libFun FSLIT("stringL")     stringLIdKey
1435 integerLName    = libFun FSLIT("integerL")    integerLIdKey
1436 intPrimLName    = libFun FSLIT("intPrimL")    intPrimLIdKey
1437 floatPrimLName  = libFun FSLIT("floatPrimL")  floatPrimLIdKey
1438 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1439 rationalLName   = libFun FSLIT("rationalL")     rationalLIdKey
1440
1441 -- data Pat = ...
1442 litPName   = libFun FSLIT("litP")   litPIdKey
1443 varPName   = libFun FSLIT("varP")   varPIdKey
1444 tupPName   = libFun FSLIT("tupP")   tupPIdKey
1445 conPName   = libFun FSLIT("conP")   conPIdKey
1446 infixPName = libFun FSLIT("infixP") infixPIdKey
1447 tildePName = libFun FSLIT("tildeP") tildePIdKey
1448 asPName    = libFun FSLIT("asP")    asPIdKey
1449 wildPName  = libFun FSLIT("wildP")  wildPIdKey
1450 recPName   = libFun FSLIT("recP")   recPIdKey
1451 listPName  = libFun FSLIT("listP")  listPIdKey
1452 sigPName   = libFun FSLIT("sigP")   sigPIdKey
1453
1454 -- type FieldPat = ...
1455 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1456
1457 -- data Match = ...
1458 matchName = libFun FSLIT("match") matchIdKey
1459
1460 -- data Clause = ...
1461 clauseName = libFun FSLIT("clause") clauseIdKey
1462
1463 -- data Exp = ...
1464 varEName        = libFun FSLIT("varE")        varEIdKey
1465 conEName        = libFun FSLIT("conE")        conEIdKey
1466 litEName        = libFun FSLIT("litE")        litEIdKey
1467 appEName        = libFun FSLIT("appE")        appEIdKey
1468 infixEName      = libFun FSLIT("infixE")      infixEIdKey
1469 infixAppName    = libFun FSLIT("infixApp")    infixAppIdKey
1470 sectionLName    = libFun FSLIT("sectionL")    sectionLIdKey
1471 sectionRName    = libFun FSLIT("sectionR")    sectionRIdKey
1472 lamEName        = libFun FSLIT("lamE")        lamEIdKey
1473 tupEName        = libFun FSLIT("tupE")        tupEIdKey
1474 condEName       = libFun FSLIT("condE")       condEIdKey
1475 letEName        = libFun FSLIT("letE")        letEIdKey
1476 caseEName       = libFun FSLIT("caseE")       caseEIdKey
1477 doEName         = libFun FSLIT("doE")         doEIdKey
1478 compEName       = libFun FSLIT("compE")       compEIdKey
1479 -- ArithSeq skips a level
1480 fromEName       = libFun FSLIT("fromE")       fromEIdKey
1481 fromThenEName   = libFun FSLIT("fromThenE")   fromThenEIdKey
1482 fromToEName     = libFun FSLIT("fromToE")     fromToEIdKey
1483 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1484 -- end ArithSeq
1485 listEName       = libFun FSLIT("listE")       listEIdKey
1486 sigEName        = libFun FSLIT("sigE")        sigEIdKey
1487 recConEName     = libFun FSLIT("recConE")     recConEIdKey
1488 recUpdEName     = libFun FSLIT("recUpdE")     recUpdEIdKey
1489
1490 -- type FieldExp = ...
1491 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1492
1493 -- data Body = ...
1494 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1495 normalBName  = libFun FSLIT("normalB")  normalBIdKey
1496
1497 -- data Guard = ...
1498 normalGEName = libFun FSLIT("normalGE") normalGEIdKey
1499 patGEName    = libFun FSLIT("patGE")    patGEIdKey
1500
1501 -- data Stmt = ...
1502 bindSName   = libFun FSLIT("bindS")   bindSIdKey
1503 letSName    = libFun FSLIT("letS")    letSIdKey
1504 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1505 parSName    = libFun FSLIT("parS")    parSIdKey
1506
1507 -- data Dec = ...
1508 funDName      = libFun FSLIT("funD")      funDIdKey
1509 valDName      = libFun FSLIT("valD")      valDIdKey
1510 dataDName     = libFun FSLIT("dataD")     dataDIdKey
1511 newtypeDName  = libFun FSLIT("newtypeD")  newtypeDIdKey
1512 tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
1513 classDName    = libFun FSLIT("classD")    classDIdKey
1514 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1515 sigDName      = libFun FSLIT("sigD")      sigDIdKey
1516 forImpDName   = libFun FSLIT("forImpD")   forImpDIdKey
1517
1518 -- type Ctxt = ...
1519 cxtName = libFun FSLIT("cxt") cxtIdKey
1520
1521 -- data Strict = ...
1522 isStrictName      = libFun  FSLIT("isStrict")      isStrictKey
1523 notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
1524
1525 -- data Con = ...
1526 normalCName = libFun FSLIT("normalC") normalCIdKey
1527 recCName    = libFun FSLIT("recC")    recCIdKey
1528 infixCName  = libFun FSLIT("infixC")  infixCIdKey
1529 forallCName  = libFun FSLIT("forallC")  forallCIdKey
1530
1531 -- type StrictType = ...
1532 strictTypeName    = libFun  FSLIT("strictType")    strictTKey
1533
1534 -- type VarStrictType = ...
1535 varStrictTypeName = libFun  FSLIT("varStrictType") varStrictTKey
1536
1537 -- data Type = ...
1538 forallTName = libFun FSLIT("forallT") forallTIdKey
1539 varTName    = libFun FSLIT("varT")    varTIdKey
1540 conTName    = libFun FSLIT("conT")    conTIdKey
1541 tupleTName  = libFun FSLIT("tupleT") tupleTIdKey
1542 arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
1543 listTName   = libFun FSLIT("listT")  listTIdKey
1544 appTName    = libFun FSLIT("appT")    appTIdKey
1545
1546 -- data Callconv = ...
1547 cCallName = libFun FSLIT("cCall") cCallIdKey
1548 stdCallName = libFun FSLIT("stdCall") stdCallIdKey
1549
1550 -- data Safety = ...
1551 unsafeName     = libFun FSLIT("unsafe") unsafeIdKey
1552 safeName       = libFun FSLIT("safe") safeIdKey
1553 threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
1554
1555 -- data FunDep = ...
1556 funDepName     = libFun FSLIT("funDep") funDepIdKey
1557
1558 matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
1559 clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
1560 expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
1561 stmtQTyConName          = libTc FSLIT("StmtQ")         stmtQTyConKey
1562 decQTyConName           = libTc FSLIT("DecQ")          decQTyConKey
1563 conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
1564 strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
1565 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1566 typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
1567 fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
1568 patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
1569 fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
1570
1571 --      TyConUniques available: 100-129
1572 --      Check in PrelNames if you want to change this
1573
1574 expTyConKey             = mkPreludeTyConUnique 100
1575 matchTyConKey           = mkPreludeTyConUnique 101
1576 clauseTyConKey          = mkPreludeTyConUnique 102
1577 qTyConKey               = mkPreludeTyConUnique 103
1578 expQTyConKey            = mkPreludeTyConUnique 104
1579 decQTyConKey            = mkPreludeTyConUnique 105
1580 patTyConKey             = mkPreludeTyConUnique 106
1581 matchQTyConKey          = mkPreludeTyConUnique 107
1582 clauseQTyConKey         = mkPreludeTyConUnique 108
1583 stmtQTyConKey           = mkPreludeTyConUnique 109
1584 conQTyConKey            = mkPreludeTyConUnique 110
1585 typeQTyConKey           = mkPreludeTyConUnique 111
1586 typeTyConKey            = mkPreludeTyConUnique 112
1587 decTyConKey             = mkPreludeTyConUnique 113
1588 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
1589 strictTypeQTyConKey     = mkPreludeTyConUnique 115
1590 fieldExpTyConKey        = mkPreludeTyConUnique 116
1591 fieldPatTyConKey        = mkPreludeTyConUnique 117
1592 nameTyConKey            = mkPreludeTyConUnique 118
1593 patQTyConKey            = mkPreludeTyConUnique 119
1594 fieldPatQTyConKey       = mkPreludeTyConUnique 120
1595 fieldExpQTyConKey       = mkPreludeTyConUnique 121
1596 funDepTyConKey          = mkPreludeTyConUnique 122
1597
1598 --      IdUniques available: 200-399
1599 --      If you want to change this, make sure you check in PrelNames
1600
1601 returnQIdKey        = mkPreludeMiscIdUnique 200
1602 bindQIdKey          = mkPreludeMiscIdUnique 201
1603 sequenceQIdKey      = mkPreludeMiscIdUnique 202
1604 liftIdKey           = mkPreludeMiscIdUnique 203
1605 newNameIdKey         = mkPreludeMiscIdUnique 204
1606 mkNameIdKey          = mkPreludeMiscIdUnique 205
1607 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
1608 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
1609 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
1610 mkNameLIdKey         = mkPreludeMiscIdUnique 209
1611
1612
1613 -- data Lit = ...
1614 charLIdKey        = mkPreludeMiscIdUnique 210
1615 stringLIdKey      = mkPreludeMiscIdUnique 211
1616 integerLIdKey     = mkPreludeMiscIdUnique 212
1617 intPrimLIdKey     = mkPreludeMiscIdUnique 213
1618 floatPrimLIdKey   = mkPreludeMiscIdUnique 214
1619 doublePrimLIdKey  = mkPreludeMiscIdUnique 215
1620 rationalLIdKey    = mkPreludeMiscIdUnique 216
1621
1622 -- data Pat = ...
1623 litPIdKey         = mkPreludeMiscIdUnique 220
1624 varPIdKey         = mkPreludeMiscIdUnique 221
1625 tupPIdKey         = mkPreludeMiscIdUnique 222
1626 conPIdKey         = mkPreludeMiscIdUnique 223
1627 infixPIdKey       = mkPreludeMiscIdUnique 312
1628 tildePIdKey       = mkPreludeMiscIdUnique 224
1629 asPIdKey          = mkPreludeMiscIdUnique 225
1630 wildPIdKey        = mkPreludeMiscIdUnique 226
1631 recPIdKey         = mkPreludeMiscIdUnique 227
1632 listPIdKey        = mkPreludeMiscIdUnique 228
1633 sigPIdKey         = mkPreludeMiscIdUnique 229
1634
1635 -- type FieldPat = ...
1636 fieldPatIdKey       = mkPreludeMiscIdUnique 230
1637
1638 -- data Match = ...
1639 matchIdKey          = mkPreludeMiscIdUnique 231
1640
1641 -- data Clause = ...
1642 clauseIdKey         = mkPreludeMiscIdUnique 232
1643
1644 -- data Exp = ...
1645 varEIdKey         = mkPreludeMiscIdUnique 240
1646 conEIdKey         = mkPreludeMiscIdUnique 241
1647 litEIdKey         = mkPreludeMiscIdUnique 242
1648 appEIdKey         = mkPreludeMiscIdUnique 243
1649 infixEIdKey       = mkPreludeMiscIdUnique 244
1650 infixAppIdKey       = mkPreludeMiscIdUnique 245
1651 sectionLIdKey       = mkPreludeMiscIdUnique 246
1652 sectionRIdKey       = mkPreludeMiscIdUnique 247
1653 lamEIdKey         = mkPreludeMiscIdUnique 248
1654 tupEIdKey         = mkPreludeMiscIdUnique 249
1655 condEIdKey        = mkPreludeMiscIdUnique 250
1656 letEIdKey         = mkPreludeMiscIdUnique 251
1657 caseEIdKey        = mkPreludeMiscIdUnique 252
1658 doEIdKey          = mkPreludeMiscIdUnique 253
1659 compEIdKey        = mkPreludeMiscIdUnique 254
1660 fromEIdKey        = mkPreludeMiscIdUnique 255
1661 fromThenEIdKey    = mkPreludeMiscIdUnique 256
1662 fromToEIdKey      = mkPreludeMiscIdUnique 257
1663 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
1664 listEIdKey        = mkPreludeMiscIdUnique 259
1665 sigEIdKey         = mkPreludeMiscIdUnique 260
1666 recConEIdKey      = mkPreludeMiscIdUnique 261
1667 recUpdEIdKey      = mkPreludeMiscIdUnique 262
1668
1669 -- type FieldExp = ...
1670 fieldExpIdKey       = mkPreludeMiscIdUnique 265
1671
1672 -- data Body = ...
1673 guardedBIdKey     = mkPreludeMiscIdUnique 266
1674 normalBIdKey      = mkPreludeMiscIdUnique 267
1675
1676 -- data Guard = ...
1677 normalGEIdKey     = mkPreludeMiscIdUnique 310
1678 patGEIdKey        = mkPreludeMiscIdUnique 311
1679
1680 -- data Stmt = ...
1681 bindSIdKey       = mkPreludeMiscIdUnique 268
1682 letSIdKey        = mkPreludeMiscIdUnique 269
1683 noBindSIdKey     = mkPreludeMiscIdUnique 270
1684 parSIdKey        = mkPreludeMiscIdUnique 271
1685
1686 -- data Dec = ...
1687 funDIdKey         = mkPreludeMiscIdUnique 272
1688 valDIdKey         = mkPreludeMiscIdUnique 273
1689 dataDIdKey        = mkPreludeMiscIdUnique 274
1690 newtypeDIdKey     = mkPreludeMiscIdUnique 275
1691 tySynDIdKey       = mkPreludeMiscIdUnique 276
1692 classDIdKey       = mkPreludeMiscIdUnique 277
1693 instanceDIdKey    = mkPreludeMiscIdUnique 278
1694 sigDIdKey         = mkPreludeMiscIdUnique 279
1695 forImpDIdKey      = mkPreludeMiscIdUnique 297
1696
1697 -- type Cxt = ...
1698 cxtIdKey            = mkPreludeMiscIdUnique 280
1699
1700 -- data Strict = ...
1701 isStrictKey         = mkPreludeMiscIdUnique 281
1702 notStrictKey        = mkPreludeMiscIdUnique 282
1703
1704 -- data Con = ...
1705 normalCIdKey      = mkPreludeMiscIdUnique 283
1706 recCIdKey         = mkPreludeMiscIdUnique 284
1707 infixCIdKey       = mkPreludeMiscIdUnique 285
1708 forallCIdKey      = mkPreludeMiscIdUnique 288
1709
1710 -- type StrictType = ...
1711 strictTKey        = mkPreludeMiscIdUnique 286
1712
1713 -- type VarStrictType = ...
1714 varStrictTKey     = mkPreludeMiscIdUnique 287
1715
1716 -- data Type = ...
1717 forallTIdKey      = mkPreludeMiscIdUnique 290
1718 varTIdKey         = mkPreludeMiscIdUnique 291
1719 conTIdKey         = mkPreludeMiscIdUnique 292
1720 tupleTIdKey       = mkPreludeMiscIdUnique 294
1721 arrowTIdKey       = mkPreludeMiscIdUnique 295
1722 listTIdKey        = mkPreludeMiscIdUnique 296
1723 appTIdKey         = mkPreludeMiscIdUnique 293
1724
1725 -- data Callconv = ...
1726 cCallIdKey      = mkPreludeMiscIdUnique 300
1727 stdCallIdKey    = mkPreludeMiscIdUnique 301
1728
1729 -- data Safety = ...
1730 unsafeIdKey     = mkPreludeMiscIdUnique 305
1731 safeIdKey       = mkPreludeMiscIdUnique 306
1732 threadsafeIdKey = mkPreludeMiscIdUnique 307
1733
1734 -- data FunDep = ...
1735 funDepIdKey = mkPreludeMiscIdUnique 320
1736