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