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