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