ghc/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, dsReify,
  15                templateHaskellNames, qTyConName,
  16                liftName, exprTyConName, declTyConName,
  17                decTyConName, typTyConName ) where
  18
  19 #include "HsVersions.h"
  20
  21 import {-# SOURCE #-}   DsExpr ( dsExpr )
  22
  23 import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup,
  24                     mkIntExpr, mkCharExpr )
  25 import DsMonad
  26
  27 import qualified Language.Haskell.THSyntax as M
  28
  29 import HsSyn      ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
  30                     Match(..), GRHSs(..), GRHS(..), HsBracket(..),
  31                     HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
  32                     HsBinds(..), MonoBinds(..), HsConDetails(..),
  33                     TyClDecl(..), HsGroup(..),
  34                     HsReify(..), ReifyFlavour(..),
  35                     HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
  36                     HsTyVarBndr(..), Sig(..), ForeignDecl(..),
  37                     InstDecl(..), ConDecl(..), BangType(..),
  38                     PendingSplice, splitHsInstDeclTy,
  39                     placeHolderType, tyClDeclNames,
  40                     collectHsBinders, collectPatBinders, collectPatsBinders,
  41                     hsTyVarName, hsConArgs, getBangType,
  42                     toHsType
  43                   )
  44
  45 import PrelNames  ( mETA_META_Name, varQual, tcQual )
  46 import MkIface    ( ifaceTyThing )
  47 import Name       ( Name, nameOccName, nameModule )
  48 import OccName    ( isDataOcc, isTvOcc, occNameUserString )
  49 import Module     ( moduleUserString )
  50 import Id         ( Id, idType )
  51 import NameEnv
  52 import NameSet
  53 import Type       ( Type, TyThing(..), mkGenTyConApp )
  54 import TyCon      ( DataConDetails(..) )
  55 import TysWiredIn ( stringTy )
  56 import CoreSyn
  57 import CoreUtils  ( exprType )
  58 import SrcLoc     ( noSrcLoc )
  59 import Maybe      ( catMaybes )
  60 import Panic      ( panic )
  61 import Unique     ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
  62 import BasicTypes ( NewOrData(..), StrictnessMark(..) )
  63
  64 import Outputable
  65 import FastString       ( mkFastString )
  66
  67 -----------------------------------------------------------------------------
  68 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  69 -- Returns a CoreExpr of type M.Expr
  70 -- The quoted thing is parameterised over Name, even though it has
  71 -- been type checked.  We don't want all those type decorations!
  72
  73 dsBracket brack splices
  74   = dsExtendMetaEnv new_bit (do_brack brack)
  75   where
  76     new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
  77
  78     do_brack (ExpBr e)  = do { MkC e1  <- repE e      ; return e1 }
  79     do_brack (PatBr p)  = do { MkC p1  <- repP p      ; return p1 }
  80     do_brack (TypBr t)  = do { MkC t1  <- repTy t     ; return t1 }
  81     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
  82
  83 -----------------------------------------------------------------------------
  84 dsReify :: HsReify Id -> DsM CoreExpr
  85 -- Returns a CoreExpr of type   reifyType --> M.Typ
  86 --                              reifyDecl --> M.Dec
  87 --                              reifyFixty --> M.Fix
  88 dsReify (ReifyOut ReifyType name)
  89   = do { thing <- dsLookupGlobal name ;
  90                 -- By deferring the lookup until now (rather than doing it
  91                 -- in the type checker) we ensure that all zonking has
  92                 -- been done.
  93          case thing of
  94             AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
  95                             return e }
  96             other   -> pprPanic "dsReify: reifyType" (ppr name)
  97         }
  98
  99 dsReify r@(ReifyOut ReifyDecl name)
 100   = do { thing <- dsLookupGlobal name ;
 101          mb_d <- repTyClD (ifaceTyThing thing) ;
 102          case mb_d of
 103            Just (MkC d) -> return d
 104            Nothing      -> pprPanic "dsReify" (ppr r)
 105         }
 106
 107 {- -------------- Examples --------------------
 108
 109   [| \x -> x |]
 110 ====>
 111   gensym (unpackString "x"#) `bindQ` \ x1::String ->
 112   lam (pvar x1) (var x1)
 113
 114
 115   [| \x -> $(f [| x |]) |]
 116 ====>
 117   gensym (unpackString "x"#) `bindQ` \ x1::String ->
 118   lam (pvar x1) (f (var x1))
 119 -}
 120
 121
 122 -------------------------------------------------------
 123 --                      Declarations
 124 -------------------------------------------------------
 125
 126 repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
 127 repTopDs group
 128  = do { let { bndrs = groupBinders group } ;
 129         ss    <- mkGenSyms bndrs ;
 130
 131         decls <- addBinds ss (do {
 132                         val_ds <- rep_binds (hs_valds group) ;
 133                         tycl_ds <- mapM repTyClD (hs_tyclds group) ;
 134                         inst_ds <- mapM repInstD (hs_instds group) ;
 135                         -- more needed
 136                         return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
 137
 138         core_list <- coreList declTyConName decls ;
 139         wrapNongenSyms ss core_list
 140         -- Do *not* gensym top-level binders
 141       }
 142
 143 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 144                         hs_fords = foreign_decls })
 145 -- Collect the binders of a Group
 146   = collectHsBinders val_decls ++
 147     [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
 148     [n | ForeignImport n _ _ _ _ <- foreign_decls]
 149
 150
 151 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
 152
 153 repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
 154                    tcdName = tc, tcdTyVars = tvs,
 155                    tcdCons = DataCons cons, tcdDerivs = mb_derivs })
 156  = do { tc1  <- lookupBinder tc ;
 157         tvs1  <- repTvs tvs ;
 158         cons1 <- mapM repC cons ;
 159         cons2 <- coreList consTyConName cons1 ;
 160         derivs1 <- repDerivs mb_derivs ;
 161         dec <- repData tc1 tvs1 cons2 derivs1 ;
 162         return (Just dec) }
 163
 164 repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
 165                       tcdTyVars = tvs, tcdFDs = [],
 166                       tcdSigs = sigs, tcdMeths = Just binds
 167         })
 168  = do { cls1 <- lookupBinder cls ;
 169         tvs1 <- repTvs tvs ;
 170         cxt1 <- repCtxt cxt ;
 171         sigs1  <- rep_sigs sigs ;
 172         binds1 <- rep_monobind binds ;
 173         decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
 174         dec <- repClass cxt1 cls1 tvs1 decls1 ;
 175         return (Just dec) }
 176
 177 -- Un-handled cases
 178 repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
 179                   return Nothing
 180              }
 181   where
 182     msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 183
 184 repInstD (InstDecl ty binds _ _ loc)
 185         -- Ignore user pragmas for now
 186  = do { cxt1 <- repCtxt cxt ;
 187         inst_ty1 <- repPred (HsClassP cls tys) ;
 188         binds1 <- rep_monobind binds ;
 189         decls1 <- coreList declTyConName binds1 ;
 190         repInst cxt1 inst_ty1 decls1  }
 191  where
 192    (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
 193
 194
 195 -------------------------------------------------------
 196 --                      Constructors
 197 -------------------------------------------------------
 198
 199 repC :: ConDecl Name -> DsM (Core M.Cons)
 200 repC (ConDecl con [] [] details loc)
 201   = do { con1     <- lookupBinder con ;
 202          arg_tys  <- mapM (repBangTy con) (hsConArgs details) ;
 203          arg_tys1 <- coreList typeTyConName arg_tys ;
 204          repConstr con1 arg_tys1 }
 205
 206 repBangTy con (BangType NotMarkedStrict ty) = repTy ty
 207 repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
 208    where
 209      msg = ptext SLIT("Ignoring stricness on argument of constructor")
 210                  <+> quotes (ppr con)
 211
 212 -------------------------------------------------------
 213 --                      Deriving clause
 214 -------------------------------------------------------
 215
 216 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
 217 repDerivs Nothing = return (coreList' stringTy [])
 218 repDerivs (Just ctxt)
 219   = do { strs <- mapM rep_deriv ctxt ;
 220          return (coreList' stringTy strs) }
 221   where
 222     rep_deriv :: HsPred Name -> DsM (Core String)
 223         -- Deriving clauses must have the simple H98 form
 224     rep_deriv (HsClassP cls []) = lookupOcc cls
 225     rep_deriv other             = panic "rep_deriv"
 226
 227
 228 -------------------------------------------------------
 229 --   Signatures in a class decl, or a group of bindings
 230 -------------------------------------------------------
 231
 232 rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
 233         -- We silently ignore ones we don't recognise
 234 rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
 235                      return (concat sigs1) }
 236
 237 rep_sig :: Sig Name -> DsM [Core M.Decl]
 238         -- Singleton => Ok
 239         -- Empty     => Too hard, signature ignored
 240 rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
 241 rep_sig (Sig nm ty _)          = rep_proto nm ty
 242 rep_sig other                  = return []
 243
 244 rep_proto nm ty = do { nm1 <- lookupBinder nm ;
 245                        ty1 <- repTy ty ;
 246                        sig <- repProto nm1 ty1 ;
 247                        return [sig] }
 248
 249
 250 -------------------------------------------------------
 251 --                      Types
 252 -------------------------------------------------------
 253
 254 repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
 255 repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
 256                   return (coreList' stringTy tvs1) }
 257
 258 -----------------
 259 repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
 260 repCtxt ctxt = do { preds <- mapM repPred ctxt;
 261                     coreList typeTyConName preds }
 262
 263 -----------------
 264 repPred :: HsPred Name -> DsM (Core M.Type)
 265 repPred (HsClassP cls tys)
 266   = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
 267          tys1 <- repTys tys; repTapps tcon tys1 }
 268 repPred (HsIParam _ _) = panic "No implicit parameters yet"
 269
 270 -----------------
 271 repTys :: [HsType Name] -> DsM [Core M.Type]
 272 repTys tys = mapM repTy tys
 273
 274 -----------------
 275 repTy :: HsType Name -> DsM (Core M.Type)
 276
 277 repTy (HsTyVar n)
 278   | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
 279   | otherwise               = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
 280 repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
 281 repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ;
 282                            tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
 283 repTy (HsListTy t)  = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
 284 repTy (HsTupleTy tc tys)          = do { tys1 <- repTys tys;
 285                                          tcon <- repTupleTyCon (length tys);
 286                                          repTapps tcon tys1 }
 287 repTy (HsOpTy ty1 HsArrow ty2)    = repTy (HsFunTy ty1 ty2)
 288 repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
 289 repTy (HsParTy t)                 = repTy t
 290 repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
 291
 292 repTy other_ty = pprPanic "repTy" (ppr other_ty)        -- HsForAllTy, HsKindSig
 293
 294 -----------------------------------------------------------------------------
 295 --              Expressions
 296 -----------------------------------------------------------------------------
 297
 298 repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
 299 repEs es = do { es'  <- mapM repE es ;
 300                 coreList exprTyConName es' }
 301
 302 repE :: HsExpr Name -> DsM (Core M.Expr)
 303 repE (HsVar x)
 304   = do { mb_val <- dsLookupMetaEnv x
 305        ; case mb_val of
 306           Nothing          -> do { str <- globalVar x
 307                                  ; repVarOrCon x str }
 308           Just (Bound y)   -> repVarOrCon x (coreVar y)
 309           Just (Splice e)  -> do { e' <- dsExpr e
 310                                  ; return (MkC e') } }
 311
 312 repE (HsIPVar x)    = panic "Can't represent implicit parameters"
 313 repE (HsLit l)      = do { a <- repLiteral l;           repLit a }
 314 repE (HsOverLit l)  = do { a <- repOverloadedLiteral l; repLit a }
 315
 316 repE (HsSplice n e loc)
 317   = do { mb_val <- dsLookupMetaEnv n
 318        ; case mb_val of
 319              Just (Splice e) -> do { e' <- dsExpr e
 320                                    ; return (MkC e') }
 321              other           -> pprPanic "HsSplice" (ppr n) }
 322
 323
 324 repE (HsLam m)      = repLambda m
 325 repE (HsApp x y)    = do {a <- repE x; b <- repE y; repApp a b}
 326 repE (NegApp x nm)  = panic "No negate yet"
 327 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
 328 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
 329
 330 repE (OpApp e1 (HsVar op) fix e2)
 331   =  do { arg1 <- repE e1;
 332           arg2 <- repE e2;
 333           the_op <- lookupOcc op ;
 334           repInfixApp arg1 the_op arg2 }
 335
 336 repE (HsCase e ms loc)
 337   = do { arg <- repE e
 338        ; ms2 <- mapM repMatchTup ms
 339        ; repCaseE arg (nonEmptyCoreList ms2) }
 340
 341 --      I havn't got the types here right yet
 342 repE (HsDo DoExpr sts _ ty loc)      = do { (ss,zs) <- repSts sts;
 343                                             e       <- repDoE (nonEmptyCoreList zs);
 344                                             wrapGenSyns expTyConName ss e }
 345 repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
 346                                           e       <- repComp (nonEmptyCoreList zs);
 347                                           wrapGenSyns expTyConName ss e }
 348
 349 repE (ArithSeqIn (From e))              = do { ds1 <- repE e; repFrom ds1 }
 350 repE (ArithSeqIn (FromThen e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2;
 351                                                repFromThen ds1 ds2 }
 352 repE (ArithSeqIn (FromTo   e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2;
 353                                                repFromTo   ds1 ds2 }
 354 repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
 355                                                ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
 356
 357 repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
 358
 359 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
 360                        ; e2 <- addBinds ss (repE e)
 361                        ; z <- repLetE ds e2
 362                        ; wrapGenSyns expTyConName ss z }
 363 repE (ExplicitList ty es)     = do { xs <- repEs es; repListExp xs }
 364 repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }
 365
 366 repE (ExplicitPArr ty es)   = panic "No parallel arrays yet"
 367 repE (RecordConOut _ _ _)   = panic "No record construction yet"
 368 repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
 369 repE (ExprWithTySig e ty)   = panic "No expressions with type signatures yet"
 370
 371
 372 -----------------------------------------------------------------------------
 373 -- Building representations of auxillary structures like Match, Clause, Stmt,
 374
 375 repMatchTup ::  Match Name -> DsM (Core M.Mtch)
 376 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
 377   do { ss1 <- mkGenSyms (collectPatBinders p)
 378      ; addBinds ss1 $ do {
 379      ; p1 <- repP p
 380      ; (ss2,ds) <- repBinds wheres
 381      ; addBinds ss2 $ do {
 382      ; gs    <- repGuards guards
 383      ; match <- repMatch p1 gs ds
 384      ; wrapGenSyns matTyConName (ss1++ss2) match }}}
 385
 386 repClauseTup ::  Match Name -> DsM (Core M.Clse)
 387 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
 388   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 389      ; addBinds ss1 $ do {
 390        ps1 <- repPs ps
 391      ; (ss2,ds) <- repBinds wheres
 392      ; addBinds ss2 $ do {
 393        gs <- repGuards guards
 394      ; clause <- repClause ps1 gs ds
 395      ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
 396
 397 repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
 398 repGuards [GRHS [ResultStmt e loc] loc2]
 399   = do {a <- repE e; repNormal a }
 400 repGuards other
 401   = do { zs <- mapM process other;
 402          repGuarded (nonEmptyCoreList (map corePair zs)) }
 403   where
 404     process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
 405            = do { x <- repE e1; y <- repE e2; return (x, y) }
 406     process other = panic "Non Haskell 98 guarded body"
 407
 408
 409 -----------------------------------------------------------------------------
 410 -- Representing Stmt's is tricky, especially if bound variables
 411 -- shaddow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 412 -- First gensym new names for every variable in any of the patterns.
 413 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 414 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 415 -- and we could reuse the original names (x and x).
 416 --
 417 -- do { x'1 <- gensym "x"
 418 --    ; x'2 <- gensym "x"
 419 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 420 --          , BindSt (pvar x'2) [| f x |]
 421 --          , NoBindSt [| g x |]
 422 --          ]
 423 --    }
 424
 425 -- The strategy is to translate a whole list of do-bindings by building a
 426 -- bigger environment, and a bigger set of meta bindings
 427 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 428 -- of the expressions within the Do
 429
 430 -----------------------------------------------------------------------------
 431 -- The helper function repSts computes the translation of each sub expression
 432 -- and a bunch of prefix bindings denoting the dynamic renaming.
 433
 434 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
 435 repSts [ResultStmt e loc] =
 436    do { a <- repE e
 437       ; e1 <- repNoBindSt a
 438       ; return ([], [e1]) }
 439 repSts (BindStmt p e loc : ss) =
 440    do { e2 <- repE e
 441       ; ss1 <- mkGenSyms (collectPatBinders p)
 442       ; addBinds ss1 $ do {
 443       ; p1 <- repP p;
 444       ; (ss2,zs) <- repSts ss
 445       ; z <- repBindSt p1 e2
 446       ; return (ss1++ss2, z : zs) }}
 447 repSts (LetStmt bs : ss) =
 448    do { (ss1,ds) <- repBinds bs
 449       ; z <- repLetSt ds
 450       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 451       ; return (ss1++ss2, z : zs) }
 452 repSts (ExprStmt e ty loc : ss) =
 453    do { e2 <- repE e
 454       ; z <- repNoBindSt e2
 455       ; (ss2,zs) <- repSts ss
 456       ; return (ss2, z : zs) }
 457 repSts other = panic "Exotic Stmt in meta brackets"
 458
 459
 460 -----------------------------------------------------------
 461 --                      Bindings
 462 -----------------------------------------------------------
 463
 464 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
 465 repBinds decs
 466  = do { let { bndrs = collectHsBinders decs } ;
 467         ss        <- mkGenSyms bndrs ;
 468         core      <- addBinds ss (rep_binds decs) ;
 469         core_list <- coreList declTyConName core ;
 470         return (ss, core_list) }
 471
 472 rep_binds :: HsBinds Name -> DsM [Core M.Decl]
 473 rep_binds EmptyBinds = return []
 474 rep_binds (ThenBinds x y)
 475  = do { core1 <- rep_binds x
 476       ; core2 <- rep_binds y
 477       ; return (core1 ++ core2) }
 478 rep_binds (MonoBind bs sigs _)
 479  = do { core1 <- rep_monobind bs
 480       ; core2 <- rep_sigs sigs
 481       ; return (core1 ++ core2) }
 482 rep_binds (IPBinds _ _)
 483   = panic "DsMeta:repBinds: can't do implicit parameters"
 484
 485 rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
 486 rep_monobind EmptyMonoBinds     = return []
 487 rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
 488                                        y1 <- rep_monobind y;
 489                                        return (x1 ++ y1) }
 490
 491 -- Note GHC treats declarations of a variable (not a pattern)
 492 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 493 -- with an empty list of patterns
 494 rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
 495  = do { (ss,wherecore) <- repBinds wheres
 496         ; guardcore <- addBinds ss (repGuards guards)
 497         ; fn' <- lookupBinder fn
 498         ; p   <- repPvar fn'
 499         ; ans <- repVal p guardcore wherecore
 500         ; return [ans] }
 501
 502 rep_monobind (FunMonoBind fn infx ms loc)
 503  =   do { ms1 <- mapM repClauseTup ms
 504         ; fn' <- lookupBinder fn
 505         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 506         ; return [ans] }
 507
 508 rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
 509  =   do { patcore <- repP pat
 510         ; (ss,wherecore) <- repBinds wheres
 511         ; guardcore <- addBinds ss (repGuards guards)
 512         ; ans <- repVal patcore guardcore wherecore
 513         ; return [ans] }
 514
 515 rep_monobind (VarMonoBind v e)
 516  =   do { v' <- lookupBinder v
 517         ; e2 <- repE e
 518         ; x <- repNormal e2
 519         ; patcore <- repPvar v'
 520         ; empty_decls <- coreList declTyConName []
 521         ; ans <- repVal patcore x empty_decls
 522         ; return [ans] }
 523
 524 -----------------------------------------------------------------------------
 525 -- Since everything in a MonoBind is mutually recursive we need rename all
 526 -- all the variables simultaneously. For example:
 527 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 528 -- do { f'1 <- gensym "f"
 529 --    ; g'2 <- gensym "g"
 530 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 531 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 532 --      ]}
 533 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 534 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 535 -- together. As we do this we collect GenSymBinds's which represent the renamed
 536 -- variables bound by the Bindings. In order not to lose track of these
 537 -- representations we build a shadow datatype MB with the same structure as
 538 -- MonoBinds, but which has slots for the representations
 539
 540
 541 -----------------------------------------------------------------------------
 542 -- GHC allows a more general form of lambda abstraction than specified
 543 -- by Haskell 98. In particular it allows guarded lambda's like :
 544 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 545 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 546 -- (\ p1 .. pn -> exp) by causing an error.
 547
 548 repLambda :: Match Name -> DsM (Core M.Expr)
 549 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
 550                              EmptyBinds _))
 551  = do { let bndrs = collectPatsBinders ps ;
 552       ; ss <- mkGenSyms bndrs
 553       ; lam <- addBinds ss (
 554                 do { xs <- repPs ps; body <- repE e; repLam xs body })
 555       ; wrapGenSyns expTyConName ss lam }
 556
 557 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 558
 559
 560 -----------------------------------------------------------------------------
 561 --                      Patterns
 562 -- repP deals with patterns.  It assumes that we have already
 563 -- walked over the pattern(s) once to collect the binders, and
 564 -- have extended the environment.  So every pattern-bound
 565 -- variable should already appear in the environment.
 566
 567 -- Process a list of patterns
 568 repPs :: [Pat Name] -> DsM (Core [M.Patt])
 569 repPs ps = do { ps' <- mapM repP ps ;
 570                 coreList pattTyConName ps' }
 571
 572 repP :: Pat Name -> DsM (Core M.Patt)
 573 repP (WildPat _)     = repPwild
 574 repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
 575 repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
 576 repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
 577 repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
 578 repP (ParPat p)      = repP p
 579 repP (ListPat ps _)  = repListPat ps
 580 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
 581 repP (ConPatIn dc details)
 582  = do { con_str <- lookupOcc dc
 583       ; case details of
 584          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
 585          RecCon pairs   -> error "No records in template haskell yet"
 586          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
 587    }
 588 repP other = panic "Exotic pattern inside meta brackets"
 589
 590 repListPat :: [Pat Name] -> DsM (Core M.Patt)
 591 repListPat []     = do { nil_con <- coreStringLit "[]"
 592                        ; nil_args <- coreList pattTyConName []
 593                        ; repPcon nil_con nil_args }
 594 repListPat (p:ps) = do { p2 <- repP p
 595                        ; ps2 <- repListPat ps
 596                        ; cons_con <- coreStringLit ":"
 597                        ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
 598
 599
 600 ----------------------------------------------------------
 601 --      The meta-environment
 602
 603 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 604                                 -- I.e.         (x, x_id) means
 605                                 --      let x_id = gensym "x" in ...
 606
 607 addBinds :: [GenSymBind] -> DsM a -> DsM a
 608 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 609
 610 lookupBinder :: Name -> DsM (Core String)
 611 lookupBinder n
 612   = do { mb_val <- dsLookupMetaEnv n;
 613          case mb_val of
 614             Just (Bound id) -> return (MkC (Var id))
 615             other           -> pprPanic "Failed binder lookup:" (ppr n) }
 616
 617 mkGenSym :: Name -> DsM GenSymBind
 618 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
 619
 620 mkGenSyms :: [Name] -> DsM [GenSymBind]
 621 mkGenSyms ns = mapM mkGenSym ns
 622
 623 lookupType :: Name      -- Name of type constructor (e.g. M.Expr)
 624            -> DsM Type  -- The type
 625 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 626                           return (mkGenTyConApp tc []) }
 627
 628 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
 629 --      --> bindQ (gensym nm1) (\ id1 ->
 630 --          bindQ (gensym nm2 (\ id2 ->
 631 --          y))
 632
 633 wrapGenSyns :: Name     -- Name of the type (consructor) for 'a'
 634             -> [GenSymBind]
 635             -> Core (M.Q a) -> DsM (Core (M.Q a))
 636 wrapGenSyns tc_name binds body@(MkC b)
 637   = do { elt_ty <- lookupType tc_name
 638        ; go elt_ty binds }
 639   where
 640     go elt_ty [] = return body
 641     go elt_ty ((name,id) : binds)
 642       = do { MkC body'  <- go elt_ty binds
 643            ; lit_str    <- localVar name
 644            ; gensym_app <- repGensym lit_str
 645            ; repBindQ stringTy elt_ty
 646                       gensym_app (MkC (Lam id body')) }
 647
 648 -- Just like wrapGenSym, but don't actually do the gensym
 649 -- Instead use the existing name
 650 -- Only used for [Decl]
 651 wrapNongenSyms :: [GenSymBind]
 652                -> Core [M.Decl] -> DsM (Core [M.Decl])
 653 wrapNongenSyms binds body@(MkC b)
 654   = go binds
 655   where
 656     go [] = return body
 657     go ((name,id) : binds)
 658       = do { MkC body'   <- go binds
 659            ; MkC lit_str <- localVar name       -- No gensym
 660            ; return (MkC (Let (NonRec id lit_str) body'))
 661            }
 662
 663 void = placeHolderType
 664
 665 string :: String -> HsExpr Id
 666 string s = HsLit (HsString (mkFastString s))
 667
 668
 669 -- %*********************************************************************
 670 -- %*                                                                   *
 671 --              Constructing code
 672 -- %*                                                                   *
 673 -- %*********************************************************************
 674
 675 -----------------------------------------------------------------------------
 676 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 677 -- we invent a new datatype which uses phantom types.
 678
 679 newtype Core a = MkC CoreExpr
 680 unC (MkC x) = x
 681
 682 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 683 rep2 n xs = do { id <- dsLookupGlobalId n
 684                ; return (MkC (foldl App (Var id) xs)) }
 685
 686 -- Then we make "repConstructors" which use the phantom types for each of the
 687 -- smart constructors of the Meta.Meta datatypes.
 688
 689
 690 -- %*********************************************************************
 691 -- %*                                                                   *
 692 --              The 'smart constructors'
 693 -- %*                                                                   *
 694 -- %*********************************************************************
 695
 696 --------------- Patterns -----------------
 697 repPlit   :: Core M.Lit -> DsM (Core M.Patt)
 698 repPlit (MkC l) = rep2 plitName [l]
 699
 700 repPvar :: Core String -> DsM (Core M.Patt)
 701 repPvar (MkC s) = rep2 pvarName [s]
 702
 703 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
 704 repPtup (MkC ps) = rep2 ptupName [ps]
 705
 706 repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
 707 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
 708
 709 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
 710 repPtilde (MkC p) = rep2 ptildeName [p]
 711
 712 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
 713 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
 714
 715 repPwild  :: DsM (Core M.Patt)
 716 repPwild = rep2 pwildName []
 717
 718 --------------- Expressions -----------------
 719 repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
 720 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
 721                    | otherwise                  = repVar str
 722
 723 repVar :: Core String -> DsM (Core M.Expr)
 724 repVar (MkC s) = rep2 varName [s]
 725
 726 repCon :: Core String -> DsM (Core M.Expr)
 727 repCon (MkC s) = rep2 conName [s]
 728
 729 repLit :: Core M.Lit -> DsM (Core M.Expr)
 730 repLit (MkC c) = rep2 litName [c]
 731
 732 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 733 repApp (MkC x) (MkC y) = rep2 appName [x,y]
 734
 735 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
 736 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
 737
 738 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
 739 repTup (MkC es) = rep2 tupName [es]
 740
 741 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 742 repCond (MkC x) (MkC y) (MkC z) =  rep2 condName [x,y,z]
 743
 744 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
 745 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 746
 747 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
 748 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 749
 750 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
 751 repDoE (MkC ss) = rep2 doEName [ss]
 752
 753 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
 754 repComp (MkC ss) = rep2 compName [ss]
 755
 756 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
 757 repListExp (MkC es) = rep2 listExpName [es]
 758
 759 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
 760 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 761
 762 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 763 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
 764
 765 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 766 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
 767
 768 ------------ Right hand sides (guarded expressions) ----
 769 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
 770 repGuarded (MkC pairs) = rep2 guardedName [pairs]
 771
 772 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
 773 repNormal (MkC e) = rep2 normalName [e]
 774
 775 ------------- Statements -------------------
 776 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
 777 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
 778
 779 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
 780 repLetSt (MkC ds) = rep2 letStName [ds]
 781
 782 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
 783 repNoBindSt (MkC e) = rep2 noBindStName [e]
 784
 785 -------------- DotDot (Arithmetic sequences) -----------
 786 repFrom :: Core M.Expr -> DsM (Core M.Expr)
 787 repFrom (MkC x) = rep2 fromName [x]
 788
 789 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 790 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
 791
 792 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 793 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
 794
 795 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 796 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
 797
 798 ------------ Match and Clause Tuples -----------
 799 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
 800 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
 801
 802 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
 803 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
 804
 805 -------------- Dec -----------------------------
 806 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
 807 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
 808
 809 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
 810 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 811
 812 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
 813 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
 814
 815 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
 816 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
 817
 818 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
 819 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
 820
 821 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
 822 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
 823
 824 repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
 825 repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
 826
 827 ------------ Types -------------------
 828
 829 repTvar :: Core String -> DsM (Core M.Type)
 830 repTvar (MkC s) = rep2 tvarName [s]
 831
 832 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
 833 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
 834
 835 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
 836 repTapps f []     = return f
 837 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 838
 839 --------- Type constructors --------------
 840
 841 repNamedTyCon :: Core String -> DsM (Core M.Type)
 842 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
 843
 844 repTupleTyCon :: Int -> DsM (Core M.Type)
 845 -- Note: not Core Int; it's easier to be direct here
 846 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
 847
 848 repArrowTyCon :: DsM (Core M.Type)
 849 repArrowTyCon = rep2 arrowTyConName []
 850
 851 repListTyCon :: DsM (Core M.Type)
 852 repListTyCon = rep2 listTyConName []
 853
 854
 855 ----------------------------------------------------------
 856 --              Literals
 857
 858 repLiteral :: HsLit -> DsM (Core M.Lit)
 859 repLiteral (HsInt i)  = rep2 intLName [mkIntExpr i]
 860 repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
 861 repLiteral x = panic "trying to represent exotic literal"
 862
 863 repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
 864 repOverloadedLiteral (HsIntegral i _)   = rep2 intLName [mkIntExpr i]
 865 repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
 866
 867
 868 --------------- Miscellaneous -------------------
 869
 870 repLift :: Core e -> DsM (Core M.Expr)
 871 repLift (MkC x) = rep2 liftName [x]
 872
 873 repGensym :: Core String -> DsM (Core (M.Q String))
 874 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
 875
 876 repBindQ :: Type -> Type        -- a and b
 877          -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
 878 repBindQ ty_a ty_b (MkC x) (MkC y)
 879   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
 880
 881 ------------ Lists and Tuples -------------------
 882 -- turn a list of patterns into a single pattern matching a list
 883
 884 coreList :: Name        -- Of the TyCon of the element type
 885          -> [Core a] -> DsM (Core [a])
 886 coreList tc_name es
 887   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
 888
 889 coreList' :: Type       -- The element type
 890           -> [Core a] -> Core [a]
 891 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
 892
 893 nonEmptyCoreList :: [Core a] -> Core [a]
 894   -- The list must be non-empty so we can get the element type
 895   -- Otherwise use coreList
 896 nonEmptyCoreList []           = panic "coreList: empty argument"
 897 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 898
 899 corePair :: (Core a, Core b) -> Core (a,b)
 900 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
 901
 902 lookupOcc :: Name -> DsM (Core String)
 903 -- Lookup an occurrence; it can't be a splice.
 904 -- Use the in-scope bindings if they exist
 905 lookupOcc n
 906   = do {  mb_val <- dsLookupMetaEnv n ;
 907           case mb_val of
 908                 Nothing        -> globalVar n
 909                 Just (Bound x) -> return (coreVar x)
 910                 other          -> pprPanic "repE:lookupOcc" (ppr n)
 911     }
 912
 913 globalVar :: Name -> DsM (Core String)
 914 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
 915             where
 916               name_mod = moduleUserString (nameModule n)
 917               name_occ = occNameUserString (nameOccName n)
 918
 919 localVar :: Name -> DsM (Core String)
 920 localVar n = coreStringLit (occNameUserString (nameOccName n))
 921
 922 coreStringLit :: String -> DsM (Core String)
 923 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
 924
 925 coreVar :: Id -> Core String    -- The Id has type String
 926 coreVar id = MkC (Var id)
 927
 928
 929
 930 -- %************************************************************************
 931 -- %*                                                                   *
 932 --              The known-key names for Template Haskell
 933 -- %*                                                                   *
 934 -- %************************************************************************
 935
 936 -- To add a name, do three things
 937 --
 938 --  1) Allocate a key
 939 --  2) Make a "Name"
 940 --  3) Add the name to knownKeyNames
 941
 942 templateHaskellNames :: NameSet
 943 -- The names that are implicitly mentioned by ``bracket''
 944 -- Should stay in sync with the import list of DsMeta
 945 templateHaskellNames
 946   = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
 947                 pconName, ptildeName, paspatName, pwildName,
 948                 varName, conName, litName, appName, infixEName, lamName,
 949                 tupName, doEName, compName,
 950                 listExpName, condName, letEName, caseEName,
 951                 infixAppName, sectionLName, sectionRName, guardedName, normalName,
 952                 bindStName, letStName, noBindStName, parStName,
 953                 fromName, fromThenName, fromToName, fromThenToName,
 954                 funName, valName, liftName,
 955                 gensymName, returnQName, bindQName,
 956                 matchName, clauseName, funName, valName, dataDName, classDName,
 957                 instName, protoName, tvarName, tconName, tappName,
 958                 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
 959                 constrName,
 960                 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
 961                 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
 962                 qTyConName, expTyConName, matTyConName, clsTyConName,
 963                 decTyConName, typTyConName ]
 964
 965
 966
 967 intLName       = varQual mETA_META_Name FSLIT("intL")          intLIdKey
 968 charLName      = varQual mETA_META_Name FSLIT("charL")         charLIdKey
 969 plitName       = varQual mETA_META_Name FSLIT("plit")          plitIdKey
 970 pvarName       = varQual mETA_META_Name FSLIT("pvar")          pvarIdKey
 971 ptupName       = varQual mETA_META_Name FSLIT("ptup")          ptupIdKey
 972 pconName       = varQual mETA_META_Name FSLIT("pcon")          pconIdKey
 973 ptildeName     = varQual mETA_META_Name FSLIT("ptilde")        ptildeIdKey
 974 paspatName     = varQual mETA_META_Name FSLIT("paspat")        paspatIdKey
 975 pwildName      = varQual mETA_META_Name FSLIT("pwild")         pwildIdKey
 976 varName        = varQual mETA_META_Name FSLIT("var")           varIdKey
 977 conName        = varQual mETA_META_Name FSLIT("con")           conIdKey
 978 litName        = varQual mETA_META_Name FSLIT("lit")           litIdKey
 979 appName        = varQual mETA_META_Name FSLIT("app")           appIdKey
 980 infixEName     = varQual mETA_META_Name FSLIT("infixE")        infixEIdKey
 981 lamName        = varQual mETA_META_Name FSLIT("lam")           lamIdKey
 982 tupName        = varQual mETA_META_Name FSLIT("tup")           tupIdKey
 983 doEName        = varQual mETA_META_Name FSLIT("doE")           doEIdKey
 984 compName       = varQual mETA_META_Name FSLIT("comp")          compIdKey
 985 listExpName    = varQual mETA_META_Name FSLIT("listExp")       listExpIdKey
 986 condName       = varQual mETA_META_Name FSLIT("cond")          condIdKey
 987 letEName       = varQual mETA_META_Name FSLIT("letE")          letEIdKey
 988 caseEName      = varQual mETA_META_Name FSLIT("caseE")         caseEIdKey
 989 infixAppName   = varQual mETA_META_Name FSLIT("infixApp")      infixAppIdKey
 990 sectionLName   = varQual mETA_META_Name FSLIT("sectionL")      sectionLIdKey
 991 sectionRName   = varQual mETA_META_Name FSLIT("sectionR")      sectionRIdKey
 992 guardedName    = varQual mETA_META_Name FSLIT("guarded")       guardedIdKey
 993 normalName     = varQual mETA_META_Name FSLIT("normal")        normalIdKey
 994 bindStName     = varQual mETA_META_Name FSLIT("bindSt")        bindStIdKey
 995 letStName      = varQual mETA_META_Name FSLIT("letSt")         letStIdKey
 996 noBindStName   = varQual mETA_META_Name FSLIT("noBindSt")      noBindStIdKey
 997 parStName      = varQual mETA_META_Name FSLIT("parSt")         parStIdKey
 998 fromName       = varQual mETA_META_Name FSLIT("from")          fromIdKey
 999 fromThenName   = varQual mETA_META_Name FSLIT("fromThen")      fromThenIdKey
1000 fromToName     = varQual mETA_META_Name FSLIT("fromTo")        fromToIdKey
1001 fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo")    fromThenToIdKey
1002 liftName       = varQual mETA_META_Name FSLIT("lift")          liftIdKey
1003 gensymName     = varQual mETA_META_Name FSLIT("gensym")        gensymIdKey
1004 returnQName    = varQual mETA_META_Name FSLIT("returnQ")       returnQIdKey
1005 bindQName      = varQual mETA_META_Name FSLIT("bindQ")         bindQIdKey
1006
1007 -- type Mat = ...
1008 matchName      = varQual mETA_META_Name FSLIT("match")         matchIdKey
1009
1010 -- type Cls = ...
1011 clauseName     = varQual mETA_META_Name FSLIT("clause")        clauseIdKey
1012
1013 -- data Dec = ...
1014 funName        = varQual mETA_META_Name FSLIT("fun")           funIdKey
1015 valName        = varQual mETA_META_Name FSLIT("val")           valIdKey
1016 dataDName      = varQual mETA_META_Name FSLIT("dataD")         dataDIdKey
1017 classDName     = varQual mETA_META_Name FSLIT("classD")        classDIdKey
1018 instName       = varQual mETA_META_Name FSLIT("inst")          instIdKey
1019 protoName      = varQual mETA_META_Name FSLIT("proto")         protoIdKey
1020
1021 -- data Typ = ...
1022 tvarName       = varQual mETA_META_Name FSLIT("tvar")          tvarIdKey
1023 tconName       = varQual mETA_META_Name FSLIT("tcon")          tconIdKey
1024 tappName       = varQual mETA_META_Name FSLIT("tapp")          tappIdKey
1025
1026 -- data Tag = ...
1027 arrowTyConName = varQual mETA_META_Name FSLIT("arrowTyCon")   arrowIdKey
1028 tupleTyConName = varQual mETA_META_Name FSLIT("tupleTyCon")   tupleIdKey
1029 listTyConName  = varQual mETA_META_Name FSLIT("listTyCon")    listIdKey
1030 namedTyConName = varQual mETA_META_Name FSLIT("namedTyCon")   namedTyConIdKey
1031
1032 -- data Con = ...
1033 constrName     = varQual mETA_META_Name FSLIT("constr")        constrIdKey
1034
1035 exprTyConName  = tcQual  mETA_META_Name FSLIT("Expr")          exprTyConKey
1036 declTyConName  = tcQual  mETA_META_Name FSLIT("Decl")          declTyConKey
1037 pattTyConName  = tcQual  mETA_META_Name FSLIT("Patt")          pattTyConKey
1038 mtchTyConName  = tcQual  mETA_META_Name FSLIT("Mtch")          mtchTyConKey
1039 clseTyConName  = tcQual  mETA_META_Name FSLIT("Clse")          clseTyConKey
1040 stmtTyConName  = tcQual  mETA_META_Name FSLIT("Stmt")          stmtTyConKey
1041 consTyConName  = tcQual  mETA_META_Name FSLIT("Cons")          consTyConKey
1042 typeTyConName  = tcQual  mETA_META_Name FSLIT("Type")          typeTyConKey
1043
1044 qTyConName     = tcQual  mETA_META_Name FSLIT("Q")             qTyConKey
1045 expTyConName   = tcQual  mETA_META_Name FSLIT("Exp")           expTyConKey
1046 decTyConName   = tcQual  mETA_META_Name FSLIT("Dec")           decTyConKey
1047 typTyConName   = tcQual  mETA_META_Name FSLIT("Typ")           typTyConKey
1048 matTyConName   = tcQual  mETA_META_Name FSLIT("Mat")           matTyConKey
1049 clsTyConName   = tcQual  mETA_META_Name FSLIT("Cls")           clsTyConKey
1050
1051 --      TyConUniques available: 100-119
1052 --      Check in PrelNames if you want to change this
1053
1054 expTyConKey  = mkPreludeTyConUnique 100
1055 matTyConKey  = mkPreludeTyConUnique 101
1056 clsTyConKey  = mkPreludeTyConUnique 102
1057 qTyConKey    = mkPreludeTyConUnique 103
1058 exprTyConKey = mkPreludeTyConUnique 104
1059 declTyConKey = mkPreludeTyConUnique 105
1060 pattTyConKey = mkPreludeTyConUnique 106
1061 mtchTyConKey = mkPreludeTyConUnique 107
1062 clseTyConKey = mkPreludeTyConUnique 108
1063 stmtTyConKey = mkPreludeTyConUnique 109
1064 consTyConKey = mkPreludeTyConUnique 110
1065 typeTyConKey = mkPreludeTyConUnique 111
1066 typTyConKey  = mkPreludeTyConUnique 112
1067 decTyConKey  = mkPreludeTyConUnique 113
1068
1069
1070
1071 --      IdUniques available: 200-299
1072 --      If you want to change this, make sure you check in PrelNames
1073 fromIdKey       = mkPreludeMiscIdUnique 200
1074 fromThenIdKey   = mkPreludeMiscIdUnique 201
1075 fromToIdKey     = mkPreludeMiscIdUnique 202
1076 fromThenToIdKey = mkPreludeMiscIdUnique 203
1077 liftIdKey       = mkPreludeMiscIdUnique 204
1078 gensymIdKey     = mkPreludeMiscIdUnique 205
1079 returnQIdKey    = mkPreludeMiscIdUnique 206
1080 bindQIdKey      = mkPreludeMiscIdUnique 207
1081 funIdKey        = mkPreludeMiscIdUnique 208
1082 valIdKey        = mkPreludeMiscIdUnique 209
1083 protoIdKey      = mkPreludeMiscIdUnique 210
1084 matchIdKey      = mkPreludeMiscIdUnique 211
1085 clauseIdKey     = mkPreludeMiscIdUnique 212
1086 intLIdKey       = mkPreludeMiscIdUnique 213
1087 charLIdKey      = mkPreludeMiscIdUnique 214
1088
1089 classDIdKey     = mkPreludeMiscIdUnique 215
1090 instIdKey       = mkPreludeMiscIdUnique 216
1091 dataDIdKey      = mkPreludeMiscIdUnique 217
1092
1093
1094 plitIdKey       = mkPreludeMiscIdUnique 220
1095 pvarIdKey       = mkPreludeMiscIdUnique 221
1096 ptupIdKey       = mkPreludeMiscIdUnique 222
1097 pconIdKey       = mkPreludeMiscIdUnique 223
1098 ptildeIdKey     = mkPreludeMiscIdUnique 224
1099 paspatIdKey     = mkPreludeMiscIdUnique 225
1100 pwildIdKey      = mkPreludeMiscIdUnique 226
1101 varIdKey        = mkPreludeMiscIdUnique 227
1102 conIdKey        = mkPreludeMiscIdUnique 228
1103 litIdKey        = mkPreludeMiscIdUnique 229
1104 appIdKey        = mkPreludeMiscIdUnique 230
1105 infixEIdKey     = mkPreludeMiscIdUnique 231
1106 lamIdKey        = mkPreludeMiscIdUnique 232
1107 tupIdKey        = mkPreludeMiscIdUnique 233
1108 doEIdKey        = mkPreludeMiscIdUnique 234
1109 compIdKey       = mkPreludeMiscIdUnique 235
1110 listExpIdKey    = mkPreludeMiscIdUnique 237
1111 condIdKey       = mkPreludeMiscIdUnique 238
1112 letEIdKey       = mkPreludeMiscIdUnique 239
1113 caseEIdKey      = mkPreludeMiscIdUnique 240
1114 infixAppIdKey   = mkPreludeMiscIdUnique 241
1115 sectionLIdKey   = mkPreludeMiscIdUnique 242
1116 sectionRIdKey   = mkPreludeMiscIdUnique 243
1117 guardedIdKey    = mkPreludeMiscIdUnique 244
1118 normalIdKey     = mkPreludeMiscIdUnique 245
1119 bindStIdKey     = mkPreludeMiscIdUnique 246
1120 letStIdKey      = mkPreludeMiscIdUnique 247
1121 noBindStIdKey   = mkPreludeMiscIdUnique 248
1122 parStIdKey      = mkPreludeMiscIdUnique 249
1123
1124 tvarIdKey       = mkPreludeMiscIdUnique 250
1125 tconIdKey       = mkPreludeMiscIdUnique 251
1126 tappIdKey       = mkPreludeMiscIdUnique 252
1127
1128 arrowIdKey      = mkPreludeMiscIdUnique 253
1129 tupleIdKey      = mkPreludeMiscIdUnique 254
1130 listIdKey       = mkPreludeMiscIdUnique 255
1131 namedTyConIdKey = mkPreludeMiscIdUnique 256
1132
1133 constrIdKey     = mkPreludeMiscIdUnique 257
1134
1135 -- %************************************************************************
1136 -- %*                                                                   *
1137 --              Other utilities
1138 -- %*                                                                   *
1139 -- %************************************************************************
1140
1141 -- It is rather usatisfactory that we don't have a SrcLoc
1142 addDsWarn :: SDoc -> DsM ()
1143 addDsWarn msg = dsWarn (noSrcLoc, msg)