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