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