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