compiler/deSugar/DsMeta.hs

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