ghc/compiler/deSugar/DsMeta.hs

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