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