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