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