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