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,
  15                templateHaskellNames, qTyConName, nameTyConName,
  16                liftName, expQTyConName, decQTyConName, typeQTyConName,
  17                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
  18                 ) where
  19
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-}   DsExpr ( dsExpr )
  23
  24 import MatchLit   ( dsLit )
  25 import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
  26 import DsMonad
  27
  28 import qualified Language.Haskell.TH as TH
  29
  30 import HsSyn      ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
  31                     Match(..), GRHSs(..), GRHS(..), HsBracket(..),
  32                     HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
  33                     HsBinds(..), MonoBinds(..), HsConDetails(..),
  34                     TyClDecl(..), HsGroup(..), HsBang(..),
  35                     HsType(..), HsContext(..), HsPred(..),
  36                     HsTyVarBndr(..), Sig(..), ForeignDecl(..),
  37                     InstDecl(..), ConDecl(..), BangType(..),
  38                     PendingSplice, splitHsInstDeclTy,
  39                     placeHolderType, tyClDeclNames,
  40                     collectHsBinders, collectPatBinders,
  41                     collectMonoBinders, collectPatsBinders,
  42                     hsTyVarName, hsConArgs
  43                   )
  44
  45 import PrelNames  ( rationalTyConName, integerTyConName, negateName )
  46 import OccName    ( isDataOcc, isTvOcc, occNameUserString )
  47 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
  48 -- we do this by removing varName from the import of OccName above, making
  49 -- a qualified instance of OccName and using OccNameAlias.varName where varName
  50 -- ws previously used in this file.
  51 import qualified OccName
  52
  53 import Module     ( Module, mkModule, mkModuleName, moduleUserString )
  54 import Id         ( Id, idType, mkLocalId )
  55 import OccName    ( mkOccFS )
  56 import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule,
  57                     isExternalName, getSrcLoc )
  58 import NameEnv
  59 import NameSet
  60 import Type       ( Type, mkGenTyConApp )
  61 import TcType     ( tcTyConAppArgs )
  62 import TyCon      ( DataConDetails(..), tyConName )
  63 import TysWiredIn ( stringTy, parrTyCon )
  64 import CoreSyn
  65 import CoreUtils  ( exprType )
  66 import SrcLoc     ( noSrcLoc )
  67 import Maybes     ( orElse )
  68 import Maybe      ( catMaybes, fromMaybe )
  69 import Panic      ( panic )
  70 import Unique     ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
  71 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
  72 import SrcLoc     ( SrcLoc )
  73 import Packages   ( thPackage )
  74 import Outputable
  75 import FastString       ( mkFastString )
  76 import FastTypes  ( iBox )
  77
  78 import Monad ( zipWithM )
  79 import List ( sortBy )
  80
  81 -----------------------------------------------------------------------------
  82 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  83 -- Returns a CoreExpr of type TH.ExpQ
  84 -- The quoted thing is parameterised over Name, even though it has
  85 -- been type checked.  We don't want all those type decorations!
  86
  87 dsBracket brack splices
  88   = dsExtendMetaEnv new_bit (do_brack brack)
  89   where
  90     new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
  91
  92     do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
  93     do_brack (ExpBr e)  = do { MkC e1  <- repE e      ; return e1 }
  94     do_brack (PatBr p)  = do { MkC p1  <- repP p      ; return p1 }
  95     do_brack (TypBr t)  = do { MkC t1  <- repTy t     ; return t1 }
  96     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
  97
  98 {- -------------- Examples --------------------
  99
 100   [| \x -> x |]
 101 ====>
 102   gensym (unpackString "x"#) `bindQ` \ x1::String ->
 103   lam (pvar x1) (var x1)
 104
 105
 106   [| \x -> $(f [| x |]) |]
 107 ====>
 108   gensym (unpackString "x"#) `bindQ` \ x1::String ->
 109   lam (pvar x1) (f (var x1))
 110 -}
 111
 112
 113 -------------------------------------------------------
 114 --                      Declarations
 115 -------------------------------------------------------
 116
 117 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 118 repTopDs group
 119  = do { let { bndrs = groupBinders group } ;
 120         ss <- mkGenSyms bndrs ;
 121
 122         -- Bind all the names mainly to avoid repeated use of explicit strings.
 123         -- Thus we get
 124         --      do { t :: String <- genSym "T" ;
 125         --           return (Data t [] ...more t's... }
 126         -- The other important reason is that the output must mention
 127         -- only "T", not "Foo:T" where Foo is the current module
 128
 129
 130         decls <- addBinds ss (do {
 131                         val_ds <- rep_binds' (hs_valds group) ;
 132                         tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
 133                         inst_ds <- mapM repInstD' (hs_instds group) ;
 134                         -- more needed
 135                         return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
 136
 137         decl_ty <- lookupType decQTyConName ;
 138         let { core_list = coreList' decl_ty decls } ;
 139
 140         dec_ty <- lookupType decTyConName ;
 141         q_decs  <- repSequenceQ dec_ty core_list ;
 142
 143         wrapNongenSyms ss q_decs
 144         -- Do *not* gensym top-level binders
 145       }
 146
 147 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 148                         hs_fords = foreign_decls })
 149 -- Collect the binders of a Group
 150   = collectHsBinders val_decls ++
 151     [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
 152     [n | ForeignImport n _ _ _ _ <- foreign_decls]
 153
 154
 155 {-      Note [Binders and occurrences]
 156         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 157 When we desugar [d| data T = MkT |]
 158 we want to get
 159         Data "T" [] [Con "MkT" []] []
 160 and *not*
 161         Data "Foo:T" [] [Con "Foo:MkT" []] []
 162 That is, the new data decl should fit into whatever new module it is
 163 asked to fit in.   We do *not* clone, though; no need for this:
 164         Data "T79" ....
 165
 166 But if we see this:
 167         data T = MkT
 168         foo = reifyDecl T
 169
 170 then we must desugar to
 171         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
 172
 173 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
 174 And we use lookupOcc, rather than lookupBinder
 175 in repTyClD and repC.
 176
 177 -}
 178
 179 repTyClD :: TyClDecl Name -> DsM (Maybe (Core TH.DecQ))
 180 repTyClD decl = do x <- repTyClD' decl
 181                    return (fmap snd x)
 182
 183 repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core TH.DecQ))
 184
 185 repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
 186                     tcdName = tc, tcdTyVars = tvs,
 187                     tcdCons = cons, tcdDerivs = mb_derivs,
 188                     tcdLoc = loc})
 189  = do { tc1 <- lookupOcc tc ;           -- See note [Binders and occurrences]
 190         dec <- addTyVarBinds tvs $ \bndrs -> do {
 191                cxt1    <- repContext cxt ;
 192                cons1   <- mapM repC cons ;
 193                cons2   <- coreList conQTyConName cons1 ;
 194                derivs1 <- repDerivs mb_derivs ;
 195                bndrs1  <- coreList nameTyConName bndrs ;
 196                repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
 197         return $ Just (loc, dec) }
 198
 199 repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt,
 200                     tcdName = tc, tcdTyVars = tvs,
 201                     tcdCons = [con], tcdDerivs = mb_derivs,
 202                     tcdLoc = loc})
 203  = do { tc1 <- lookupOcc tc ;           -- See note [Binders and occurrences]
 204         dec <- addTyVarBinds tvs $ \bndrs -> do {
 205                cxt1   <- repContext cxt ;
 206                con1   <- repC con ;
 207                derivs1 <- repDerivs mb_derivs ;
 208                bndrs1  <- coreList nameTyConName bndrs ;
 209                repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
 210         return $ Just (loc, dec) }
 211
 212 repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
 213            tcdLoc = loc})
 214  = do { tc1 <- lookupOcc tc ;           -- See note [Binders and occurrences]
 215         dec <- addTyVarBinds tvs $ \bndrs -> do {
 216                ty1     <- repTy ty ;
 217                bndrs1  <- coreList nameTyConName bndrs ;
 218                repTySyn tc1 bndrs1 ty1 } ;
 219         return (Just (loc, dec)) }
 220
 221 repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
 222                       tcdTyVars = tvs,
 223                       tcdFDs = [],      -- We don't understand functional dependencies
 224                       tcdSigs = sigs, tcdMeths = meth_binds,
 225               tcdLoc = loc})
 226  = do { cls1 <- lookupOcc cls ;         -- See note [Binders and occurrences]
 227         dec  <- addTyVarBinds tvs $ \bndrs -> do {
 228                   cxt1   <- repContext cxt ;
 229                   sigs1  <- rep_sigs sigs ;
 230                   binds1 <- rep_monobind meth_binds ;
 231                   decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
 232                   bndrs1 <- coreList nameTyConName bndrs ;
 233                   repClass cxt1 cls1 bndrs1 decls1 } ;
 234         return $ Just (loc, dec) }
 235
 236 -- Un-handled cases
 237 repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
 238                   return Nothing
 239              }
 240   where
 241     msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 242
 243 repInstD' (InstDecl ty binds _ loc)
 244         -- Ignore user pragmas for now
 245  = do   { cxt1 <- repContext cxt
 246         ; inst_ty1 <- repPred (HsClassP cls tys)
 247         ; ss <- mkGenSyms (collectMonoBinders binds)
 248         ; binds1 <- addBinds ss (rep_monobind binds)
 249         ; decls1 <- coreList decQTyConName binds1
 250         ; decls2 <- wrapNongenSyms ss decls1
 251                 -- wrapNonGenSyms: do not clone the class op names!
 252                 -- They must be called 'op' etc, not 'op34'
 253         ; i <- repInst cxt1 inst_ty1 decls2
 254         ; return (loc, i)}
 255  where
 256    (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
 257
 258
 259 -------------------------------------------------------
 260 --                      Constructors
 261 -------------------------------------------------------
 262
 263 repC :: ConDecl Name -> DsM (Core TH.ConQ)
 264 repC (ConDecl con [] [] details loc)
 265   = do { con1     <- lookupOcc con ;            -- See note [Binders and occurrences]
 266          repConstr con1 details }
 267
 268 repBangTy :: BangType Name -> DsM (Core (TH.StrictTypeQ))
 269 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
 270                                  MkC t <- repTy ty
 271                                  rep2 strictTypeName [s, t]
 272     where strName = case str of
 273                         HsNoBang -> notStrictName
 274                         other    -> isStrictName
 275
 276 -------------------------------------------------------
 277 --                      Deriving clause
 278 -------------------------------------------------------
 279
 280 repDerivs :: Maybe (HsContext Name) -> DsM (Core [TH.Name])
 281 repDerivs Nothing = coreList nameTyConName []
 282 repDerivs (Just ctxt)
 283   = do { strs <- mapM rep_deriv ctxt ;
 284          coreList nameTyConName strs }
 285   where
 286     rep_deriv :: HsPred Name -> DsM (Core TH.Name)
 287         -- Deriving clauses must have the simple H98 form
 288     rep_deriv (HsClassP cls []) = lookupOcc cls
 289     rep_deriv other             = panic "rep_deriv"
 290
 291
 292 -------------------------------------------------------
 293 --   Signatures in a class decl, or a group of bindings
 294 -------------------------------------------------------
 295
 296 rep_sigs :: [Sig Name] -> DsM [Core TH.DecQ]
 297 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
 298                    return $ de_loc $ sort_by_loc locs_cores
 299
 300 rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core TH.DecQ)]
 301         -- We silently ignore ones we don't recognise
 302 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 303                      return (concat sigs1) }
 304
 305 rep_sig :: Sig Name -> DsM [(SrcLoc, Core TH.DecQ)]
 306         -- Singleton => Ok
 307         -- Empty     => Too hard, signature ignored
 308 rep_sig (Sig nm ty loc) = rep_proto nm ty loc
 309 rep_sig other           = return []
 310
 311 rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core TH.DecQ)]
 312 rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
 313                        ty1 <- repTy ty ;
 314                        sig <- repProto nm1 ty1 ;
 315                        return [(loc, sig)] }
 316
 317
 318 -------------------------------------------------------
 319 --                      Types
 320 -------------------------------------------------------
 321
 322 -- gensym a list of type variables and enter them into the meta environment;
 323 -- the computations passed as the second argument is executed in that extended
 324 -- meta environment and gets the *new* names on Core-level as an argument
 325 --
 326 addTyVarBinds :: [HsTyVarBndr Name]              -- the binders to be added
 327               -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
 328               -> DsM (Core (TH.Q a))
 329 addTyVarBinds tvs m =
 330   do
 331     let names = map hsTyVarName tvs
 332     freshNames <- mkGenSyms names
 333     term       <- addBinds freshNames $ do
 334                     bndrs <- mapM lookupBinder names
 335                     m bndrs
 336     wrapGenSyns freshNames term
 337
 338 -- represent a type context
 339 --
 340 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 341 repContext ctxt = do
 342                     preds    <- mapM repPred ctxt
 343                     predList <- coreList typeQTyConName preds
 344                     repCtxt predList
 345
 346 -- represent a type predicate
 347 --
 348 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
 349 repPred (HsClassP cls tys) = do
 350                                tcon <- repTy (HsTyVar cls)
 351                                tys1 <- repTys tys
 352                                repTapps tcon tys1
 353 repPred (HsIParam _ _)     =
 354   panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
 355
 356 -- yield the representation of a list of types
 357 --
 358 repTys :: [HsType Name] -> DsM [Core TH.TypeQ]
 359 repTys tys = mapM repTy tys
 360
 361 -- represent a type
 362 --
 363 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 364 repTy (HsForAllTy _ tvs ctxt ty)  =
 365   addTyVarBinds tvs $ \bndrs -> do
 366     ctxt1  <- repContext ctxt
 367     ty1    <- repTy ty
 368     bndrs1 <- coreList nameTyConName bndrs
 369     repTForall bndrs1 ctxt1 ty1
 370
 371 repTy (HsTyVar n)
 372   | isTvOcc (nameOccName n)       = do
 373                                       tv1 <- lookupBinder n
 374                                       repTvar tv1
 375   | otherwise                     = do
 376                                       tc1 <- lookupOcc n
 377                                       repNamedTyCon tc1
 378 repTy (HsAppTy f a)               = do
 379                                       f1 <- repTy f
 380                                       a1 <- repTy a
 381                                       repTapp f1 a1
 382 repTy (HsFunTy f a)               = do
 383                                       f1   <- repTy f
 384                                       a1   <- repTy a
 385                                       tcon <- repArrowTyCon
 386                                       repTapps tcon [f1, a1]
 387 repTy (HsListTy t)                = do
 388                                       t1   <- repTy t
 389                                       tcon <- repListTyCon
 390                                       repTapp tcon t1
 391 repTy (HsPArrTy t)                = do
 392                                       t1   <- repTy t
 393                                       tcon <- repTy (HsTyVar (tyConName parrTyCon))
 394                                       repTapp tcon t1
 395 repTy (HsTupleTy tc tys)          = do
 396                                       tys1 <- repTys tys
 397                                       tcon <- repTupleTyCon (length tys)
 398                                       repTapps tcon tys1
 399 repTy (HsOpTy ty1 n ty2)          = repTy ((HsTyVar n `HsAppTy` ty1)
 400                                            `HsAppTy` ty2)
 401 repTy (HsParTy t)                 = repTy t
 402 repTy (HsNumTy i)                 =
 403   panic "DsMeta.repTy: Can't represent number types (for generics)"
 404 repTy (HsPredTy pred)             = repPred pred
 405 repTy (HsKindSig ty kind)         =
 406   panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
 407
 408
 409 -----------------------------------------------------------------------------
 410 --              Expressions
 411 -----------------------------------------------------------------------------
 412
 413 repEs :: [HsExpr Name] -> DsM (Core [TH.ExpQ])
 414 repEs es = do { es'  <- mapM repE es ;
 415                 coreList expQTyConName es' }
 416
 417 -- FIXME: some of these panics should be converted into proper error messages
 418 --        unless we can make sure that constructs, which are plainly not
 419 --        supported in TH already lead to error messages at an earlier stage
 420 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 421 repE (HsVar x)            =
 422   do { mb_val <- dsLookupMetaEnv x
 423      ; case mb_val of
 424         Nothing          -> do { str <- globalVar x
 425                                ; repVarOrCon x str }
 426         Just (Bound y)   -> repVarOrCon x (coreVar y)
 427         Just (Splice e)  -> do { e' <- dsExpr e
 428                                ; return (MkC e') } }
 429 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
 430
 431         -- Remember, we're desugaring renamer output here, so
 432         -- HsOverlit can definitely occur
 433 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 434 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 435 repE (HsLam m)     = repLambda m
 436 repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
 437
 438 repE (OpApp e1 op fix e2) =
 439   do { arg1 <- repE e1;
 440        arg2 <- repE e2;
 441        the_op <- repE op ;
 442        repInfixApp arg1 the_op arg2 }
 443 repE (NegApp x nm)        = do
 444                               a         <- repE x
 445                               negateVar <- lookupOcc negateName >>= repVar
 446                               negateVar `repApp` a
 447 repE (HsPar x)            = repE x
 448 repE (SectionL x y)       = do { a <- repE x; b <- repE y; repSectionL a b }
 449 repE (SectionR x y)       = do { a <- repE x; b <- repE y; repSectionR a b }
 450 repE (HsCase e ms loc)    = do { arg <- repE e
 451                                ; ms2 <- mapM repMatchTup ms
 452                                ; repCaseE arg (nonEmptyCoreList ms2) }
 453 repE (HsIf x y z loc)     = do
 454                               a <- repE x
 455                               b <- repE y
 456                               c <- repE z
 457                               repCond a b c
 458 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 459                                ; e2 <- addBinds ss (repE e)
 460                                ; z <- repLetE ds e2
 461                                ; wrapGenSyns ss z }
 462 -- FIXME: I haven't got the types here right yet
 463 repE (HsDo DoExpr sts _ ty loc)
 464  = do { (ss,zs) <- repSts sts;
 465         e       <- repDoE (nonEmptyCoreList zs);
 466         wrapGenSyns ss e }
 467 repE (HsDo ListComp sts _ ty loc)
 468  = do { (ss,zs) <- repSts sts;
 469         e       <- repComp (nonEmptyCoreList zs);
 470         wrapGenSyns ss e }
 471 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 472 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
 473 repE (ExplicitPArr ty es) =
 474   panic "DsMeta.repE: No explicit parallel arrays yet"
 475 repE (ExplicitTuple es boxed)
 476   | isBoxed boxed         = do { xs <- repEs es; repTup xs }
 477   | otherwise             = panic "DsMeta.repE: Can't represent unboxed tuples"
 478 repE (RecordCon c flds)
 479  = do { x <- lookupOcc c;
 480         fs <- repFields flds;
 481         repRecCon x fs }
 482 repE (RecordUpd e flds)
 483  = do { x <- repE e;
 484         fs <- repFields flds;
 485         repRecUpd x fs }
 486
 487 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
 488 repE (ArithSeqIn aseq) =
 489   case aseq of
 490     From e              -> do { ds1 <- repE e; repFrom ds1 }
 491     FromThen e1 e2      -> do
 492                              ds1 <- repE e1
 493                              ds2 <- repE e2
 494                              repFromThen ds1 ds2
 495     FromTo   e1 e2      -> do
 496                              ds1 <- repE e1
 497                              ds2 <- repE e2
 498                              repFromTo ds1 ds2
 499     FromThenTo e1 e2 e3 -> do
 500                              ds1 <- repE e1
 501                              ds2 <- repE e2
 502                              ds3 <- repE e3
 503                              repFromThenTo ds1 ds2 ds3
 504 repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
 505 repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
 506 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 507 repE (HsBracketOut _ _)   =
 508   panic "DsMeta.repE: Can't represent Oxford brackets"
 509 repE (HsSplice n e loc)   = do { mb_val <- dsLookupMetaEnv n
 510                                ; case mb_val of
 511                                  Just (Splice e) -> do { e' <- dsExpr e
 512                                                        ; return (MkC e') }
 513                                  other       -> pprPanic "HsSplice" (ppr n) }
 514 repE e                    =
 515   pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
 516
 517 -----------------------------------------------------------------------------
 518 -- Building representations of auxillary structures like Match, Clause, Stmt,
 519
 520 repMatchTup ::  Match Name -> DsM (Core TH.MatchQ)
 521 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
 522   do { ss1 <- mkGenSyms (collectPatBinders p)
 523      ; addBinds ss1 $ do {
 524      ; p1 <- repP p
 525      ; (ss2,ds) <- repBinds wheres
 526      ; addBinds ss2 $ do {
 527      ; gs    <- repGuards guards
 528      ; match <- repMatch p1 gs ds
 529      ; wrapGenSyns (ss1++ss2) match }}}
 530
 531 repClauseTup ::  Match Name -> DsM (Core TH.ClauseQ)
 532 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
 533   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 534      ; addBinds ss1 $ do {
 535        ps1 <- repPs ps
 536      ; (ss2,ds) <- repBinds wheres
 537      ; addBinds ss2 $ do {
 538        gs <- repGuards guards
 539      ; clause <- repClause ps1 gs ds
 540      ; wrapGenSyns (ss1++ss2) clause }}}
 541
 542 repGuards ::  [GRHS Name] ->  DsM (Core TH.BodyQ)
 543 repGuards [GRHS [ResultStmt e loc] loc2]
 544   = do {a <- repE e; repNormal a }
 545 repGuards other
 546   = do { zs <- mapM process other;
 547          repGuarded (nonEmptyCoreList (map corePair zs)) }
 548   where
 549     process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
 550            = do { x <- repE e1; y <- repE e2; return (x, y) }
 551     process other = panic "Non Haskell 98 guarded body"
 552
 553 repFields :: [(Name,HsExpr Name)] -> DsM (Core [TH.FieldExp])
 554 repFields flds = do
 555         fnames <- mapM lookupOcc (map fst flds)
 556         es <- mapM repE (map snd flds)
 557         fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
 558         coreList fieldExpTyConName fs
 559
 560
 561 -----------------------------------------------------------------------------
 562 -- Representing Stmt's is tricky, especially if bound variables
 563 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 564 -- First gensym new names for every variable in any of the patterns.
 565 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 566 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 567 -- and we could reuse the original names (x and x).
 568 --
 569 -- do { x'1 <- gensym "x"
 570 --    ; x'2 <- gensym "x"
 571 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 572 --          , BindSt (pvar x'2) [| f x |]
 573 --          , NoBindSt [| g x |]
 574 --          ]
 575 --    }
 576
 577 -- The strategy is to translate a whole list of do-bindings by building a
 578 -- bigger environment, and a bigger set of meta bindings
 579 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 580 -- of the expressions within the Do
 581
 582 -----------------------------------------------------------------------------
 583 -- The helper function repSts computes the translation of each sub expression
 584 -- and a bunch of prefix bindings denoting the dynamic renaming.
 585
 586 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 587 repSts [ResultStmt e loc] =
 588    do { a <- repE e
 589       ; e1 <- repNoBindSt a
 590       ; return ([], [e1]) }
 591 repSts (BindStmt p e loc : ss) =
 592    do { e2 <- repE e
 593       ; ss1 <- mkGenSyms (collectPatBinders p)
 594       ; addBinds ss1 $ do {
 595       ; p1 <- repP p;
 596       ; (ss2,zs) <- repSts ss
 597       ; z <- repBindSt p1 e2
 598       ; return (ss1++ss2, z : zs) }}
 599 repSts (LetStmt bs : ss) =
 600    do { (ss1,ds) <- repBinds bs
 601       ; z <- repLetSt ds
 602       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 603       ; return (ss1++ss2, z : zs) }
 604 repSts (ExprStmt e ty loc : ss) =
 605    do { e2 <- repE e
 606       ; z <- repNoBindSt e2
 607       ; (ss2,zs) <- repSts ss
 608       ; return (ss2, z : zs) }
 609 repSts other = panic "Exotic Stmt in meta brackets"
 610
 611
 612 -----------------------------------------------------------
 613 --                      Bindings
 614 -----------------------------------------------------------
 615
 616 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 617 repBinds decs
 618  = do   { let { bndrs = collectHsBinders decs }
 619                 -- No need to worrry about detailed scopes within
 620                 -- the binding group, because we are talking Names
 621                 -- here, so we can safely treat it as a mutually
 622                 -- recursive group
 623         ; ss        <- mkGenSyms bndrs
 624         ; core      <- addBinds ss (rep_binds decs)
 625         ; core_list <- coreList decQTyConName core
 626         ; return (ss, core_list) }
 627
 628 rep_binds :: HsBinds Name -> DsM [Core TH.DecQ]
 629 -- Assumes: all the binders of the binding are alrady in the meta-env
 630 rep_binds binds = do locs_cores <- rep_binds' binds
 631                      return $ de_loc $ sort_by_loc locs_cores
 632
 633 rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core TH.DecQ)]
 634 -- Assumes: all the binders of the binding are alrady in the meta-env
 635 rep_binds' EmptyBinds = return []
 636 rep_binds' (ThenBinds x y)
 637  = do { core1 <- rep_binds' x
 638       ; core2 <- rep_binds' y
 639       ; return (core1 ++ core2) }
 640 rep_binds' (MonoBind bs sigs _)
 641  = do { core1 <- rep_monobind' bs
 642       ; core2 <- rep_sigs' sigs
 643       ; return (core1 ++ core2) }
 644 rep_binds' (IPBinds _)
 645   = panic "DsMeta:repBinds: can't do implicit parameters"
 646
 647 rep_monobind :: MonoBinds Name -> DsM [Core TH.DecQ]
 648 -- Assumes: all the binders of the binding are alrady in the meta-env
 649 rep_monobind binds = do locs_cores <- rep_monobind' binds
 650                         return $ de_loc $ sort_by_loc locs_cores
 651
 652 rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core TH.DecQ)]
 653 -- Assumes: all the binders of the binding are alrady in the meta-env
 654 rep_monobind' EmptyMonoBinds     = return []
 655 rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
 656                                        y1 <- rep_monobind' y;
 657                                        return (x1 ++ y1) }
 658
 659 -- Note GHC treats declarations of a variable (not a pattern)
 660 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 661 -- with an empty list of patterns
 662 rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
 663  = do { (ss,wherecore) <- repBinds wheres
 664         ; guardcore <- addBinds ss (repGuards guards)
 665         ; fn' <- lookupBinder fn
 666         ; p   <- repPvar fn'
 667         ; ans <- repVal p guardcore wherecore
 668         ; return [(loc, ans)] }
 669
 670 rep_monobind' (FunMonoBind fn infx ms loc)
 671  =   do { ms1 <- mapM repClauseTup ms
 672         ; fn' <- lookupBinder fn
 673         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 674         ; return [(loc, ans)] }
 675
 676 rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
 677  =   do { patcore <- repP pat
 678         ; (ss,wherecore) <- repBinds wheres
 679         ; guardcore <- addBinds ss (repGuards guards)
 680         ; ans <- repVal patcore guardcore wherecore
 681         ; return [(loc, ans)] }
 682
 683 rep_monobind' (VarMonoBind v e)
 684  =   do { v' <- lookupBinder v
 685         ; e2 <- repE e
 686         ; x <- repNormal e2
 687         ; patcore <- repPvar v'
 688         ; empty_decls <- coreList decQTyConName []
 689         ; ans <- repVal patcore x empty_decls
 690         ; return [(getSrcLoc v, ans)] }
 691
 692 -----------------------------------------------------------------------------
 693 -- Since everything in a MonoBind is mutually recursive we need rename all
 694 -- all the variables simultaneously. For example:
 695 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 696 -- do { f'1 <- gensym "f"
 697 --    ; g'2 <- gensym "g"
 698 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 699 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 700 --      ]}
 701 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 702 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 703 -- together. As we do this we collect GenSymBinds's which represent the renamed
 704 -- variables bound by the Bindings. In order not to lose track of these
 705 -- representations we build a shadow datatype MB with the same structure as
 706 -- MonoBinds, but which has slots for the representations
 707
 708
 709 -----------------------------------------------------------------------------
 710 -- GHC allows a more general form of lambda abstraction than specified
 711 -- by Haskell 98. In particular it allows guarded lambda's like :
 712 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 713 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 714 -- (\ p1 .. pn -> exp) by causing an error.
 715
 716 repLambda :: Match Name -> DsM (Core TH.ExpQ)
 717 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
 718                              EmptyBinds _))
 719  = do { let bndrs = collectPatsBinders ps ;
 720       ; ss  <- mkGenSyms bndrs
 721       ; lam <- addBinds ss (
 722                 do { xs <- repPs ps; body <- repE e; repLam xs body })
 723       ; wrapGenSyns ss lam }
 724
 725 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 726
 727
 728 -----------------------------------------------------------------------------
 729 --                      Patterns
 730 -- repP deals with patterns.  It assumes that we have already
 731 -- walked over the pattern(s) once to collect the binders, and
 732 -- have extended the environment.  So every pattern-bound
 733 -- variable should already appear in the environment.
 734
 735 -- Process a list of patterns
 736 repPs :: [Pat Name] -> DsM (Core [TH.Pat])
 737 repPs ps = do { ps' <- mapM repP ps ;
 738                 coreList patTyConName ps' }
 739
 740 repP :: Pat Name -> DsM (Core TH.Pat)
 741 repP (WildPat _)     = repPwild
 742 repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
 743 repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
 744 repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
 745 repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
 746 repP (ParPat p)      = repP p
 747 repP (ListPat ps _)  = do { qs <- repPs ps; repPlist qs }
 748 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
 749 repP (ConPatIn dc details)
 750  = do { con_str <- lookupOcc dc
 751       ; case details of
 752          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
 753          RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
 754                             ; ps <- sequence $ map repP (map snd pairs)
 755                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
 756                             ; fps' <- coreList fieldPatTyConName fps
 757                             ; repPrec con_str fps' }
 758          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
 759    }
 760 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
 761 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
 762 repP other = panic "Exotic pattern inside meta brackets"
 763
 764 ----------------------------------------------------------
 765 -- Declaration ordering helpers
 766
 767 sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
 768 sort_by_loc xs = sortBy comp xs
 769     where comp x y = compare (fst x) (fst y)
 770
 771 de_loc :: [(SrcLoc, a)] -> [a]
 772 de_loc = map snd
 773
 774 ----------------------------------------------------------
 775 --      The meta-environment
 776
 777 -- A name/identifier association for fresh names of locally bound entities
 778 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 779                                 -- I.e.         (x, x_id) means
 780                                 --      let x_id = gensym "x" in ...
 781
 782 -- Generate a fresh name for a locally bound entity
 783
 784 mkGenSyms :: [Name] -> DsM [GenSymBind]
 785 -- We can use the existing name.  For example:
 786 --      [| \x_77 -> x_77 + x_77 |]
 787 -- desugars to
 788 --      do { x_77 <- genSym "x"; .... }
 789 -- We use the same x_77 in the desugared program, but with the type Bndr
 790 -- instead of Int
 791 --
 792 -- We do make it an Internal name, though (hence localiseName)
 793 --
 794 -- Nevertheless, it's monadic because we have to generate nameTy
 795 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
 796                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
 797
 798
 799 addBinds :: [GenSymBind] -> DsM a -> DsM a
 800 -- Add a list of fresh names for locally bound entities to the
 801 -- meta environment (which is part of the state carried around
 802 -- by the desugarer monad)
 803 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 804
 805 -- Look up a locally bound name
 806 --
 807 lookupBinder :: Name -> DsM (Core TH.Name)
 808 lookupBinder n
 809   = do { mb_val <- dsLookupMetaEnv n;
 810          case mb_val of
 811             Just (Bound x) -> return (coreVar x)
 812             other          -> pprPanic "Failed binder lookup:" (ppr n) }
 813
 814 -- Look up a name that is either locally bound or a global name
 815 --
 816 -- * If it is a global name, generate the "original name" representation (ie,
 817 --   the <module>:<name> form) for the associated entity
 818 --
 819 lookupOcc :: Name -> DsM (Core TH.Name)
 820 -- Lookup an occurrence; it can't be a splice.
 821 -- Use the in-scope bindings if they exist
 822 lookupOcc n
 823   = do {  mb_val <- dsLookupMetaEnv n ;
 824           case mb_val of
 825                 Nothing         -> globalVar n
 826                 Just (Bound x)  -> return (coreVar x)
 827                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
 828     }
 829
 830 globalVar :: Name -> DsM (Core TH.Name)
 831 -- Not bound by the meta-env
 832 -- Could be top-level; or could be local
 833 --      f x = $(g [| x |])
 834 -- Here the x will be local
 835 globalVar name
 836   | isExternalName name
 837   = do  { MkC mod <- coreStringLit name_mod
 838         ; MkC occ <- occNameLit name
 839         ; rep2 mk_varg [mod,occ] }
 840   | otherwise
 841   = do  { MkC occ <- occNameLit name
 842         ; MkC uni <- coreIntLit (getKey (getUnique name))
 843         ; rep2 mkNameUName [occ,uni] }
 844   where
 845       name_mod = moduleUserString (nameModule name)
 846       name_occ = nameOccName name
 847       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
 848               | OccName.isVarOcc  name_occ = mkNameG_vName
 849               | OccName.isTcOcc   name_occ = mkNameG_tcName
 850               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
 851
 852 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
 853            -> DsM Type  -- The type
 854 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 855                           return (mkGenTyConApp tc []) }
 856
 857 wrapGenSyns :: [GenSymBind]
 858             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
 859 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
 860 --      --> bindQ (gensym nm1) (\ id1 ->
 861 --          bindQ (gensym nm2 (\ id2 ->
 862 --          y))
 863
 864 wrapGenSyns binds body@(MkC b)
 865   = do  { var_ty <- lookupType nameTyConName
 866         ; go var_ty binds }
 867   where
 868     [elt_ty] = tcTyConAppArgs (exprType b)
 869         -- b :: Q a, so we can get the type 'a' by looking at the
 870         -- argument type. NB: this relies on Q being a data/newtype,
 871         -- not a type synonym
 872
 873     go var_ty [] = return body
 874     go var_ty ((name,id) : binds)
 875       = do { MkC body'  <- go var_ty binds
 876            ; lit_str    <- occNameLit name
 877            ; gensym_app <- repGensym lit_str
 878            ; repBindQ var_ty elt_ty
 879                       gensym_app (MkC (Lam id body')) }
 880
 881 -- Just like wrapGenSym, but don't actually do the gensym
 882 -- Instead use the existing name:
 883 --      let x = "x" in ...
 884 -- Only used for [Decl], and for the class ops in class
 885 -- and instance decls
 886 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
 887 wrapNongenSyms binds (MkC body)
 888   = do { binds' <- mapM do_one binds ;
 889          return (MkC (mkLets binds' body)) }
 890   where
 891     do_one (name,id)
 892         = do { MkC lit_str <- occNameLit name
 893              ; MkC var <- rep2 mkNameName [lit_str]
 894              ; return (NonRec id var) }
 895
 896 occNameLit :: Name -> DsM (Core String)
 897 occNameLit n = coreStringLit (occNameUserString (nameOccName n))
 898
 899 void = placeHolderType
 900
 901 string :: String -> HsExpr Id
 902 string s = HsLit (HsString (mkFastString s))
 903
 904
 905 -- %*********************************************************************
 906 -- %*                                                                   *
 907 --              Constructing code
 908 -- %*                                                                   *
 909 -- %*********************************************************************
 910
 911 -----------------------------------------------------------------------------
 912 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 913 -- we invent a new datatype which uses phantom types.
 914
 915 newtype Core a = MkC CoreExpr
 916 unC (MkC x) = x
 917
 918 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 919 rep2 n xs = do { id <- dsLookupGlobalId n
 920                ; return (MkC (foldl App (Var id) xs)) }
 921
 922 -- Then we make "repConstructors" which use the phantom types for each of the
 923 -- smart constructors of the Meta.Meta datatypes.
 924
 925
 926 -- %*********************************************************************
 927 -- %*                                                                   *
 928 --              The 'smart constructors'
 929 -- %*                                                                   *
 930 -- %*********************************************************************
 931
 932 --------------- Patterns -----------------
 933 repPlit   :: Core TH.Lit -> DsM (Core TH.Pat)
 934 repPlit (MkC l) = rep2 litPName [l]
 935
 936 repPvar :: Core TH.Name -> DsM (Core TH.Pat)
 937 repPvar (MkC s) = rep2 varPName [s]
 938
 939 repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat)
 940 repPtup (MkC ps) = rep2 tupPName [ps]
 941
 942 repPcon   :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat)
 943 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
 944
 945 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat)
 946 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
 947
 948 repPtilde :: Core TH.Pat -> DsM (Core TH.Pat)
 949 repPtilde (MkC p) = rep2 tildePName [p]
 950
 951 repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat)
 952 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
 953
 954 repPwild  :: DsM (Core TH.Pat)
 955 repPwild = rep2 wildPName []
 956
 957 repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat)
 958 repPlist (MkC ps) = rep2 listPName [ps]
 959
 960 --------------- Expressions -----------------
 961 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
 962 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
 963                    | otherwise                  = repVar str
 964
 965 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
 966 repVar (MkC s) = rep2 varEName [s]
 967
 968 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
 969 repCon (MkC s) = rep2 conEName [s]
 970
 971 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
 972 repLit (MkC c) = rep2 litEName [c]
 973
 974 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 975 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
 976
 977 repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 978 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 979
 980 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 981 repTup (MkC es) = rep2 tupEName [es]
 982
 983 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 984 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
 985
 986 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 987 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 988
 989 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
 990 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 991
 992 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 993 repDoE (MkC ss) = rep2 doEName [ss]
 994
 995 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
 996 repComp (MkC ss) = rep2 compEName [ss]
 997
 998 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
 999 repListExp (MkC es) = rep2 listEName [es]
1000
1001 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1002 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1003
1004 repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ)
1005 repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
1006
1007 repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ)
1008 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1009
1010 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1011 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1012
1013 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1014 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1015
1016 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1017 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1018
1019 ------------ Right hand sides (guarded expressions) ----
1020 repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ)
1021 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1022
1023 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1024 repNormal (MkC e) = rep2 normalBName [e]
1025
1026 ------------- Stmts -------------------
1027 repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1028 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1029
1030 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1031 repLetSt (MkC ds) = rep2 letSName [ds]
1032
1033 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1034 repNoBindSt (MkC e) = rep2 noBindSName [e]
1035
1036 -------------- Range (Arithmetic sequences) -----------
1037 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1038 repFrom (MkC x) = rep2 fromEName [x]
1039
1040 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1041 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1042
1043 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1044 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1045
1046 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1047 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1048
1049 ------------ Match and Clause Tuples -----------
1050 repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1051 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1052
1053 repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1054 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1055
1056 -------------- Dec -----------------------------
1057 repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1058 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1059
1060 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1061 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1062
1063 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1064 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1065     = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1066
1067 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1068 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1069     = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1070
1071 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1072 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1073
1074 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1075 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1076
1077 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1078 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1079
1080 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1081 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1082
1083 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1084 repCtxt (MkC tys) = rep2 cxtName [tys]
1085
1086 repConstr :: Core TH.Name -> HsConDetails Name (BangType Name)
1087           -> DsM (Core TH.ConQ)
1088 repConstr con (PrefixCon ps)
1089     = do arg_tys  <- mapM repBangTy ps
1090          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1091          rep2 normalCName [unC con, unC arg_tys1]
1092 repConstr con (RecCon ips)
1093     = do arg_vs   <- mapM lookupOcc (map fst ips)
1094          arg_tys  <- mapM repBangTy (map snd ips)
1095          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1096                               arg_vs arg_tys
1097          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1098          rep2 recCName [unC con, unC arg_vtys']
1099 repConstr con (InfixCon st1 st2)
1100     = do arg1 <- repBangTy st1
1101          arg2 <- repBangTy st2
1102          rep2 infixCName [unC arg1, unC con, unC arg2]
1103
1104 ------------ Types -------------------
1105
1106 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1107 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1108     = rep2 forallTName [tvars, ctxt, ty]
1109
1110 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1111 repTvar (MkC s) = rep2 varTName [s]
1112
1113 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1114 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1115
1116 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1117 repTapps f []     = return f
1118 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1119
1120 --------- Type constructors --------------
1121
1122 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1123 repNamedTyCon (MkC s) = rep2 conTName [s]
1124
1125 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1126 -- Note: not Core Int; it's easier to be direct here
1127 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1128
1129 repArrowTyCon :: DsM (Core TH.TypeQ)
1130 repArrowTyCon = rep2 arrowTName []
1131
1132 repListTyCon :: DsM (Core TH.TypeQ)
1133 repListTyCon = rep2 listTName []
1134
1135
1136 ----------------------------------------------------------
1137 --              Literals
1138
1139 repLiteral :: HsLit -> DsM (Core TH.Lit)
1140 repLiteral lit
1141   = do lit' <- case lit of
1142                    HsIntPrim i    -> mk_integer i
1143                    HsInt i        -> mk_integer i
1144                    HsFloatPrim r  -> mk_rational r
1145                    HsDoublePrim r -> mk_rational r
1146                    _ -> return lit
1147        lit_expr <- dsLit lit'
1148        rep2 lit_name [lit_expr]
1149   where
1150     lit_name = case lit of
1151                  HsInteger _ _  -> integerLName
1152                  HsInt     _    -> integerLName
1153                  HsIntPrim _    -> intPrimLName
1154                  HsFloatPrim _  -> floatPrimLName
1155                  HsDoublePrim _ -> doublePrimLName
1156                  HsChar _       -> charLName
1157                  HsString _     -> stringLName
1158                  HsRat _ _      -> rationalLName
1159                  other          -> uh_oh
1160     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1161                     (ppr lit)
1162
1163 mk_integer  i = do integer_ty <- lookupType integerTyConName
1164                    return $ HsInteger i integer_ty
1165 mk_rational r = do rat_ty <- lookupType rationalTyConName
1166                    return $ HsRat r rat_ty
1167
1168 repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
1169 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
1170 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1171         -- The type Rational will be in the environment, becuase
1172         -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1173         -- and rationalL is sucked in when any TH stuff is used
1174
1175 --------------- Miscellaneous -------------------
1176
1177 repLift :: Core e -> DsM (Core TH.ExpQ)
1178 repLift (MkC x) = rep2 liftName [x]
1179
1180 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1181 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1182
1183 repBindQ :: Type -> Type        -- a and b
1184          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1185 repBindQ ty_a ty_b (MkC x) (MkC y)
1186   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1187
1188 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1189 repSequenceQ ty_a (MkC list)
1190   = rep2 sequenceQName [Type ty_a, list]
1191
1192 ------------ Lists and Tuples -------------------
1193 -- turn a list of patterns into a single pattern matching a list
1194
1195 coreList :: Name        -- Of the TyCon of the element type
1196          -> [Core a] -> DsM (Core [a])
1197 coreList tc_name es
1198   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1199
1200 coreList' :: Type       -- The element type
1201           -> [Core a] -> Core [a]
1202 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1203
1204 nonEmptyCoreList :: [Core a] -> Core [a]
1205   -- The list must be non-empty so we can get the element type
1206   -- Otherwise use coreList
1207 nonEmptyCoreList []           = panic "coreList: empty argument"
1208 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1209
1210 corePair :: (Core a, Core b) -> Core (a,b)
1211 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1212
1213 coreStringLit :: String -> DsM (Core String)
1214 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1215
1216 coreIntLit :: Int -> DsM (Core Int)
1217 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1218
1219 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1220 coreVar id = MkC (Var id)
1221
1222
1223
1224 -- %************************************************************************
1225 -- %*                                                                   *
1226 --              The known-key names for Template Haskell
1227 -- %*                                                                   *
1228 -- %************************************************************************
1229
1230 -- To add a name, do three things
1231 --
1232 --  1) Allocate a key
1233 --  2) Make a "Name"
1234 --  3) Add the name to knownKeyNames
1235
1236 templateHaskellNames :: [Name]
1237 -- The names that are implicitly mentioned by ``bracket''
1238 -- Should stay in sync with the import list of DsMeta
1239
1240 templateHaskellNames = [
1241     returnQName, bindQName, sequenceQName, newNameName, liftName,
1242     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName,
1243
1244     -- Lit
1245     charLName, stringLName, integerLName, intPrimLName,
1246     floatPrimLName, doublePrimLName, rationalLName,
1247     -- Pat
1248     litPName, varPName, tupPName, conPName, tildePName,
1249     asPName, wildPName, recPName, listPName,
1250     -- FieldPat
1251     fieldPatName,
1252     -- Match
1253     matchName,
1254     -- Clause
1255     clauseName,
1256     -- Exp
1257     varEName, conEName, litEName, appEName, infixEName,
1258     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1259     condEName, letEName, caseEName, doEName, compEName,
1260     fromEName, fromThenEName, fromToEName, fromThenToEName,
1261     listEName, sigEName, recConEName, recUpdEName,
1262     -- FieldExp
1263     fieldExpName,
1264     -- Body
1265     guardedBName, normalBName,
1266     -- Stmt
1267     bindSName, letSName, noBindSName, parSName,
1268     -- Dec
1269     funDName, valDName, dataDName, newtypeDName, tySynDName,
1270     classDName, instanceDName, sigDName,
1271     -- Cxt
1272     cxtName,
1273     -- Strict
1274     isStrictName, notStrictName,
1275     -- Con
1276     normalCName, recCName, infixCName,
1277     -- StrictType
1278     strictTypeName,
1279     -- VarStrictType
1280     varStrictTypeName,
1281     -- Type
1282     forallTName, varTName, conTName, appTName,
1283     tupleTName, arrowTName, listTName,
1284
1285     -- And the tycons
1286     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1287     clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1288     decQTyConName, conQTyConName, strictTypeQTyConName,
1289     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1290     typeTyConName, matchTyConName, clauseTyConName]
1291
1292 tH_SYN_Name = mkModuleName "Language.Haskell.TH.THSyntax"
1293 tH_LIB_Name = mkModuleName "Language.Haskell.TH.THLib"
1294
1295 thSyn :: Module
1296 -- NB: the THSyntax module comes from the "haskell-src" package
1297 thSyn = mkModule thPackage  tH_SYN_Name
1298 thLib = mkModule thPackage  tH_LIB_Name
1299
1300 mk_known_key_name mod space str uniq
1301   = mkExternalName uniq mod (mkOccFS space str)
1302                    Nothing noSrcLoc
1303
1304 libFun = mk_known_key_name thLib OccName.varName
1305 libTc  = mk_known_key_name thLib OccName.tcName
1306 thFun  = mk_known_key_name thSyn OccName.varName
1307 thTc   = mk_known_key_name thSyn OccName.tcName
1308
1309 -------------------- THSyntax -----------------------
1310 qTyConName        = thTc FSLIT("Q")             qTyConKey
1311 nameTyConName      = thTc FSLIT("Name")           nameTyConKey
1312 fieldExpTyConName = thTc FSLIT("FieldExp")      fieldExpTyConKey
1313 patTyConName      = thTc FSLIT("Pat")           patTyConKey
1314 fieldPatTyConName = thTc FSLIT("FieldPat")      fieldPatTyConKey
1315 expTyConName      = thTc  FSLIT("Exp")          expTyConKey
1316 decTyConName      = thTc  FSLIT("Dec")          decTyConKey
1317 typeTyConName     = thTc  FSLIT("Type")         typeTyConKey
1318 matchTyConName    = thTc  FSLIT("Match")        matchTyConKey
1319 clauseTyConName   = thTc  FSLIT("Clause")       clauseTyConKey
1320
1321 returnQName   = thFun FSLIT("returnQ")   returnQIdKey
1322 bindQName     = thFun FSLIT("bindQ")     bindQIdKey
1323 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1324 newNameName    = thFun FSLIT("newName")   newNameIdKey
1325 liftName      = thFun FSLIT("lift")      liftIdKey
1326 mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
1327 mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
1328 mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
1329 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1330 mkNameUName    = thFun FSLIT("mkNameU")    mkNameUIdKey
1331
1332
1333 -------------------- THLib -----------------------
1334 -- data Lit = ...
1335 charLName       = libFun FSLIT("charL")       charLIdKey
1336 stringLName     = libFun FSLIT("stringL")     stringLIdKey
1337 integerLName    = libFun FSLIT("integerL")    integerLIdKey
1338 intPrimLName    = libFun FSLIT("intPrimL")    intPrimLIdKey
1339 floatPrimLName  = libFun FSLIT("floatPrimL")  floatPrimLIdKey
1340 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1341 rationalLName   = libFun FSLIT("rationalL")     rationalLIdKey
1342
1343 -- data Pat = ...
1344 litPName   = libFun FSLIT("litP")   litPIdKey
1345 varPName   = libFun FSLIT("varP")   varPIdKey
1346 tupPName   = libFun FSLIT("tupP")   tupPIdKey
1347 conPName   = libFun FSLIT("conP")   conPIdKey
1348 tildePName = libFun FSLIT("tildeP") tildePIdKey
1349 asPName    = libFun FSLIT("asP")    asPIdKey
1350 wildPName  = libFun FSLIT("wildP")  wildPIdKey
1351 recPName   = libFun FSLIT("recP")   recPIdKey
1352 listPName  = libFun FSLIT("listP")  listPIdKey
1353
1354 -- type FieldPat = ...
1355 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1356
1357 -- data Match = ...
1358 matchName = libFun FSLIT("match") matchIdKey
1359
1360 -- data Clause = ...
1361 clauseName = libFun FSLIT("clause") clauseIdKey
1362
1363 -- data Exp = ...
1364 varEName        = libFun FSLIT("varE")        varEIdKey
1365 conEName        = libFun FSLIT("conE")        conEIdKey
1366 litEName        = libFun FSLIT("litE")        litEIdKey
1367 appEName        = libFun FSLIT("appE")        appEIdKey
1368 infixEName      = libFun FSLIT("infixE")      infixEIdKey
1369 infixAppName    = libFun FSLIT("infixApp")    infixAppIdKey
1370 sectionLName    = libFun FSLIT("sectionL")    sectionLIdKey
1371 sectionRName    = libFun FSLIT("sectionR")    sectionRIdKey
1372 lamEName        = libFun FSLIT("lamE")        lamEIdKey
1373 tupEName        = libFun FSLIT("tupE")        tupEIdKey
1374 condEName       = libFun FSLIT("condE")       condEIdKey
1375 letEName        = libFun FSLIT("letE")        letEIdKey
1376 caseEName       = libFun FSLIT("caseE")       caseEIdKey
1377 doEName         = libFun FSLIT("doE")         doEIdKey
1378 compEName       = libFun FSLIT("compE")       compEIdKey
1379 -- ArithSeq skips a level
1380 fromEName       = libFun FSLIT("fromE")       fromEIdKey
1381 fromThenEName   = libFun FSLIT("fromThenE")   fromThenEIdKey
1382 fromToEName     = libFun FSLIT("fromToE")     fromToEIdKey
1383 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1384 -- end ArithSeq
1385 listEName       = libFun FSLIT("listE")       listEIdKey
1386 sigEName        = libFun FSLIT("sigE")        sigEIdKey
1387 recConEName     = libFun FSLIT("recConE")     recConEIdKey
1388 recUpdEName     = libFun FSLIT("recUpdE")     recUpdEIdKey
1389
1390 -- type FieldExp = ...
1391 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1392
1393 -- data Body = ...
1394 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1395 normalBName  = libFun FSLIT("normalB")  normalBIdKey
1396
1397 -- data Stmt = ...
1398 bindSName   = libFun FSLIT("bindS")   bindSIdKey
1399 letSName    = libFun FSLIT("letS")    letSIdKey
1400 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1401 parSName    = libFun FSLIT("parS")    parSIdKey
1402
1403 -- data Dec = ...
1404 funDName      = libFun FSLIT("funD")      funDIdKey
1405 valDName      = libFun FSLIT("valD")      valDIdKey
1406 dataDName     = libFun FSLIT("dataD")     dataDIdKey
1407 newtypeDName  = libFun FSLIT("newtypeD")  newtypeDIdKey
1408 tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
1409 classDName    = libFun FSLIT("classD")    classDIdKey
1410 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1411 sigDName      = libFun FSLIT("sigD")      sigDIdKey
1412
1413 -- type Ctxt = ...
1414 cxtName = libFun FSLIT("cxt") cxtIdKey
1415
1416 -- data Strict = ...
1417 isStrictName      = libFun  FSLIT("isStrict")      isStrictKey
1418 notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
1419
1420 -- data Con = ...
1421 normalCName = libFun FSLIT("normalC") normalCIdKey
1422 recCName    = libFun FSLIT("recC")    recCIdKey
1423 infixCName  = libFun FSLIT("infixC")  infixCIdKey
1424
1425 -- type StrictType = ...
1426 strictTypeName    = libFun  FSLIT("strictType")    strictTKey
1427
1428 -- type VarStrictType = ...
1429 varStrictTypeName = libFun  FSLIT("varStrictType") varStrictTKey
1430
1431 -- data Type = ...
1432 forallTName = libFun FSLIT("forallT") forallTIdKey
1433 varTName    = libFun FSLIT("varT")    varTIdKey
1434 conTName    = libFun FSLIT("conT")    conTIdKey
1435 tupleTName  = libFun FSLIT("tupleT") tupleTIdKey
1436 arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
1437 listTName   = libFun FSLIT("listT")  listTIdKey
1438 appTName    = libFun FSLIT("appT")    appTIdKey
1439
1440 matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
1441 clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
1442 expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
1443 stmtQTyConName          = libTc FSLIT("StmtQ")         stmtQTyConKey
1444 decQTyConName           = libTc FSLIT("DecQ")          decQTyConKey
1445 conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
1446 strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
1447 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1448 typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
1449
1450 --      TyConUniques available: 100-119
1451 --      Check in PrelNames if you want to change this
1452
1453 expTyConKey             = mkPreludeTyConUnique 100
1454 matchTyConKey           = mkPreludeTyConUnique 101
1455 clauseTyConKey          = mkPreludeTyConUnique 102
1456 qTyConKey               = mkPreludeTyConUnique 103
1457 expQTyConKey            = mkPreludeTyConUnique 104
1458 decQTyConKey            = mkPreludeTyConUnique 105
1459 patTyConKey             = mkPreludeTyConUnique 106
1460 matchQTyConKey          = mkPreludeTyConUnique 107
1461 clauseQTyConKey         = mkPreludeTyConUnique 108
1462 stmtQTyConKey           = mkPreludeTyConUnique 109
1463 conQTyConKey            = mkPreludeTyConUnique 110
1464 typeQTyConKey           = mkPreludeTyConUnique 111
1465 typeTyConKey            = mkPreludeTyConUnique 112
1466 decTyConKey             = mkPreludeTyConUnique 113
1467 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
1468 strictTypeQTyConKey     = mkPreludeTyConUnique 115
1469 fieldExpTyConKey        = mkPreludeTyConUnique 116
1470 fieldPatTyConKey        = mkPreludeTyConUnique 117
1471 nameTyConKey             = mkPreludeTyConUnique 118
1472
1473 --      IdUniques available: 200-299
1474 --      If you want to change this, make sure you check in PrelNames
1475
1476 returnQIdKey        = mkPreludeMiscIdUnique 200
1477 bindQIdKey          = mkPreludeMiscIdUnique 201
1478 sequenceQIdKey      = mkPreludeMiscIdUnique 202
1479 liftIdKey           = mkPreludeMiscIdUnique 203
1480 newNameIdKey         = mkPreludeMiscIdUnique 204
1481 mkNameIdKey          = mkPreludeMiscIdUnique 205
1482 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
1483 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
1484 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
1485 mkNameUIdKey         = mkPreludeMiscIdUnique 209
1486
1487
1488 -- data Lit = ...
1489 charLIdKey        = mkPreludeMiscIdUnique 210
1490 stringLIdKey      = mkPreludeMiscIdUnique 211
1491 integerLIdKey     = mkPreludeMiscIdUnique 212
1492 intPrimLIdKey     = mkPreludeMiscIdUnique 213
1493 floatPrimLIdKey   = mkPreludeMiscIdUnique 214
1494 doublePrimLIdKey  = mkPreludeMiscIdUnique 215
1495 rationalLIdKey    = mkPreludeMiscIdUnique 216
1496
1497 -- data Pat = ...
1498 litPIdKey         = mkPreludeMiscIdUnique 220
1499 varPIdKey         = mkPreludeMiscIdUnique 221
1500 tupPIdKey         = mkPreludeMiscIdUnique 222
1501 conPIdKey         = mkPreludeMiscIdUnique 223
1502 tildePIdKey       = mkPreludeMiscIdUnique 224
1503 asPIdKey          = mkPreludeMiscIdUnique 225
1504 wildPIdKey        = mkPreludeMiscIdUnique 226
1505 recPIdKey         = mkPreludeMiscIdUnique 227
1506 listPIdKey        = mkPreludeMiscIdUnique 228
1507
1508 -- type FieldPat = ...
1509 fieldPatIdKey       = mkPreludeMiscIdUnique 230
1510
1511 -- data Match = ...
1512 matchIdKey          = mkPreludeMiscIdUnique 231
1513
1514 -- data Clause = ...
1515 clauseIdKey         = mkPreludeMiscIdUnique 232
1516
1517 -- data Exp = ...
1518 varEIdKey         = mkPreludeMiscIdUnique 240
1519 conEIdKey         = mkPreludeMiscIdUnique 241
1520 litEIdKey         = mkPreludeMiscIdUnique 242
1521 appEIdKey         = mkPreludeMiscIdUnique 243
1522 infixEIdKey       = mkPreludeMiscIdUnique 244
1523 infixAppIdKey       = mkPreludeMiscIdUnique 245
1524 sectionLIdKey       = mkPreludeMiscIdUnique 246
1525 sectionRIdKey       = mkPreludeMiscIdUnique 247
1526 lamEIdKey         = mkPreludeMiscIdUnique 248
1527 tupEIdKey         = mkPreludeMiscIdUnique 249
1528 condEIdKey        = mkPreludeMiscIdUnique 250
1529 letEIdKey         = mkPreludeMiscIdUnique 251
1530 caseEIdKey        = mkPreludeMiscIdUnique 252
1531 doEIdKey          = mkPreludeMiscIdUnique 253
1532 compEIdKey        = mkPreludeMiscIdUnique 254
1533 fromEIdKey        = mkPreludeMiscIdUnique 255
1534 fromThenEIdKey    = mkPreludeMiscIdUnique 256
1535 fromToEIdKey      = mkPreludeMiscIdUnique 257
1536 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
1537 listEIdKey        = mkPreludeMiscIdUnique 259
1538 sigEIdKey         = mkPreludeMiscIdUnique 260
1539 recConEIdKey      = mkPreludeMiscIdUnique 261
1540 recUpdEIdKey      = mkPreludeMiscIdUnique 262
1541
1542 -- type FieldExp = ...
1543 fieldExpIdKey       = mkPreludeMiscIdUnique 265
1544
1545 -- data Body = ...
1546 guardedBIdKey     = mkPreludeMiscIdUnique 266
1547 normalBIdKey      = mkPreludeMiscIdUnique 267
1548
1549 -- data Stmt = ...
1550 bindSIdKey       = mkPreludeMiscIdUnique 268
1551 letSIdKey        = mkPreludeMiscIdUnique 269
1552 noBindSIdKey     = mkPreludeMiscIdUnique 270
1553 parSIdKey        = mkPreludeMiscIdUnique 271
1554
1555 -- data Dec = ...
1556 funDIdKey         = mkPreludeMiscIdUnique 272
1557 valDIdKey         = mkPreludeMiscIdUnique 273
1558 dataDIdKey        = mkPreludeMiscIdUnique 274
1559 newtypeDIdKey     = mkPreludeMiscIdUnique 275
1560 tySynDIdKey       = mkPreludeMiscIdUnique 276
1561 classDIdKey       = mkPreludeMiscIdUnique 277
1562 instanceDIdKey    = mkPreludeMiscIdUnique 278
1563 sigDIdKey         = mkPreludeMiscIdUnique 279
1564
1565 -- type Cxt = ...
1566 cxtIdKey            = mkPreludeMiscIdUnique 280
1567
1568 -- data Strict = ...
1569 isStrictKey         = mkPreludeMiscIdUnique 281
1570 notStrictKey        = mkPreludeMiscIdUnique 282
1571
1572 -- data Con = ...
1573 normalCIdKey      = mkPreludeMiscIdUnique 283
1574 recCIdKey         = mkPreludeMiscIdUnique 284
1575 infixCIdKey       = mkPreludeMiscIdUnique 285
1576
1577 -- type StrictType = ...
1578 strictTKey        = mkPreludeMiscIdUnique 2286
1579
1580 -- type VarStrictType = ...
1581 varStrictTKey     = mkPreludeMiscIdUnique 287
1582
1583 -- data Type = ...
1584 forallTIdKey      = mkPreludeMiscIdUnique 290
1585 varTIdKey         = mkPreludeMiscIdUnique 291
1586 conTIdKey         = mkPreludeMiscIdUnique 292
1587 tupleTIdKey       = mkPreludeMiscIdUnique 294
1588 arrowTIdKey       = mkPreludeMiscIdUnique 295
1589 listTIdKey        = mkPreludeMiscIdUnique 296
1590 appTIdKey         = mkPreludeMiscIdUnique 293
1591
1592 -- %************************************************************************
1593 -- %*                                                                   *
1594 --              Other utilities
1595 -- %*                                                                   *
1596 -- %************************************************************************
1597
1598 -- It is rather usatisfactory that we don't have a SrcLoc
1599 addDsWarn :: SDoc -> DsM ()
1600 addDsWarn msg = dsWarn (noSrcLoc, msg)
1601