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