ghc/compiler/deSugar/DsMeta.hs

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