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