compiler/deSugar/DsMeta.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow 2006
   4 --
   5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
   6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
   7 -- input HsExpr. We do this in the DsM monad, which supplies access to
   8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
   9 --
  10 -- It also defines a bunch of knownKeyNames, in the same way as is done
  11 -- in prelude/PrelNames.  It's much more convenient to do it here, becuase
  12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
  13 -- a Royal Pain (triggers other recompilation).
  14 -----------------------------------------------------------------------------
  15
  16 module DsMeta( dsBracket,
  17                templateHaskellNames, qTyConName, nameTyConName,
  18                liftName, liftStringName, expQTyConName, patQTyConName,
  19                decQTyConName, decsQTyConName, typeQTyConName,
  20                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
  21                quoteExpName, quotePatName, quoteDecName, quoteTypeName
  22                 ) where
  23
  24 #include "HsVersions.h"
  25
  26 import {-# SOURCE #-}   DsExpr ( dsExpr )
  27
  28 import MatchLit
  29 import DsMonad
  30
  31 import qualified Language.Haskell.TH as TH
  32
  33 import HsSyn
  34 import Class
  35 import PrelNames
  36 -- To avoid clashes with DsMeta.varName we must make a local alias for
  37 -- OccName.varName we do this by removing varName from the import of
  38 -- OccName above, making a qualified instance of OccName and using
  39 -- OccNameAlias.varName where varName ws previously used in this file.
  40 import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
  41
  42 import Module
  43 import Id
  44 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
  45 import NameEnv
  46 import TcType
  47 import TyCon
  48 import TysWiredIn
  49 import CoreSyn
  50 import MkCore
  51 import CoreUtils
  52 import SrcLoc
  53 import Unique
  54 import BasicTypes
  55 import Outputable
  56 import Bag
  57 import FastString
  58 import ForeignCall
  59 import MonadUtils
  60
  61 import Data.Maybe
  62 import Control.Monad
  63 import Data.List
  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  <- repTopP p   ; return p1 }
  79     do_brack (TypBr t)   = do { MkC t1  <- repLTy t    ; return t1 }
  80     do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
  81     do_brack (DecBrL _)  = panic "dsBracket: unexpected DecBrL"
  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 repTopP :: LPat Name -> DsM (Core TH.PatQ)
 103 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 104                  ; pat' <- addBinds ss (repLP pat)
 105                  ; wrapNongenSyms ss pat' }
 106
 107 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 108 repTopDs group
 109  = do { let { bndrs = hsGroupBinders group } ;
 110         ss <- mkGenSyms bndrs ;
 111
 112         -- Bind all the names mainly to avoid repeated use of explicit strings.
 113         -- Thus we get
 114         --      do { t :: String <- genSym "T" ;
 115         --           return (Data t [] ...more t's... }
 116         -- The other important reason is that the output must mention
 117         -- only "T", not "Foo:T" where Foo is the current module
 118
 119
 120         decls <- addBinds ss (do {
 121                         val_ds  <- rep_val_binds (hs_valds group) ;
 122                         tycl_ds <- mapM repTyClD (hs_tyclds group) ;
 123                         inst_ds <- mapM repInstD' (hs_instds group) ;
 124                         for_ds <- mapM repForD (hs_fords group) ;
 125                         -- more needed
 126                         return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
 127
 128         decl_ty <- lookupType decQTyConName ;
 129         let { core_list = coreList' decl_ty decls } ;
 130
 131         dec_ty <- lookupType decTyConName ;
 132         q_decs  <- repSequenceQ dec_ty core_list ;
 133
 134         wrapNongenSyms ss q_decs
 135         -- Do *not* gensym top-level binders
 136       }
 137
 138
 139 {-      Note [Binders and occurrences]
 140         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 141 When we desugar [d| data T = MkT |]
 142 we want to get
 143         Data "T" [] [Con "MkT" []] []
 144 and *not*
 145         Data "Foo:T" [] [Con "Foo:MkT" []] []
 146 That is, the new data decl should fit into whatever new module it is
 147 asked to fit in.   We do *not* clone, though; no need for this:
 148         Data "T79" ....
 149
 150 But if we see this:
 151         data T = MkT
 152         foo = reifyDecl T
 153
 154 then we must desugar to
 155         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
 156
 157 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
 158 And we use lookupOcc, rather than lookupBinder
 159 in repTyClD and repC.
 160
 161 -}
 162
 163 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 164
 165 repTyClD tydecl@(L _ (TyFamily {}))
 166   = repTyFamily tydecl addTyVarBinds
 167
 168 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
 169                           tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 170                           tcdCons = cons, tcdDerivs = mb_derivs }))
 171   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 172        ; dec <- addTyVarBinds tvs $ \bndrs ->
 173            do { cxt1     <- repLContext cxt
 174               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 175               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 176               ; cons1    <- mapM repC cons
 177               ; cons2    <- coreList conQTyConName cons1
 178               ; derivs1  <- repDerivs mb_derivs
 179               ; bndrs1   <- coreList tyVarBndrTyConName bndrs
 180               ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
 181               }
 182        ; return $ Just (loc, dec)
 183        }
 184
 185 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
 186                           tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 187                           tcdCons = [con], tcdDerivs = mb_derivs }))
 188   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 189        ; dec <- addTyVarBinds tvs $ \bndrs ->
 190            do { cxt1     <- repLContext cxt
 191               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 192               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 193               ; con1     <- repC con
 194               ; derivs1  <- repDerivs mb_derivs
 195               ; bndrs1   <- coreList tyVarBndrTyConName bndrs
 196               ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
 197               }
 198        ; return $ Just (loc, dec)
 199        }
 200
 201 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 202                              tcdSynRhs = ty }))
 203   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 204        ; dec <- addTyVarBinds tvs $ \bndrs ->
 205            do { opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
 206               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 207               ; ty1      <- repLTy ty
 208               ; bndrs1   <- coreList tyVarBndrTyConName bndrs
 209               ; repTySyn tc1 bndrs1 opt_tys2 ty1
 210               }
 211        ; return (Just (loc, dec))
 212        }
 213
 214 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
 215                              tcdTyVars = tvs, tcdFDs = fds,
 216                              tcdSigs = sigs, tcdMeths = meth_binds,
 217                              tcdATs = ats }))
 218   = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
 219        ; dec  <- addTyVarBinds tvs $ \bndrs ->
 220            do { cxt1   <- repLContext cxt
 221               ; sigs1  <- rep_sigs sigs
 222               ; binds1 <- rep_binds meth_binds
 223               ; fds1   <- repLFunDeps fds
 224               ; ats1   <- repLAssocFamilys ats
 225               ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
 226               ; bndrs1 <- coreList tyVarBndrTyConName bndrs
 227               ; repClass cxt1 cls1 bndrs1 fds1 decls1
 228               }
 229        ; return $ Just (loc, dec)
 230        }
 231
 232 -- Un-handled cases
 233 repTyClD (L loc d) = putSrcSpanDs loc $
 234                      do { warnDs (hang ds_msg 4 (ppr d))
 235                         ; return Nothing }
 236
 237 -- The type variables in the head of families are treated differently when the
 238 -- family declaration is associated.  In that case, they are usage, not binding
 239 -- occurences.
 240 --
 241 repTyFamily :: LTyClDecl Name
 242             -> ProcessTyVarBinds TH.Dec
 243             -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 244 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
 245                                tcdLName = tc, tcdTyVars = tvs,
 246                                tcdKind = opt_kind }))
 247             tyVarBinds
 248   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
 249        ; dec <- tyVarBinds tvs $ \bndrs ->
 250            do { flav   <- repFamilyFlavour flavour
 251               ; bndrs1 <- coreList tyVarBndrTyConName bndrs
 252               ; case opt_kind of
 253                   Nothing -> repFamilyNoKind flav tc1 bndrs1
 254                   Just ki -> do { ki1 <- repKind ki
 255                                 ; repFamilyKind flav tc1 bndrs1 ki1
 256                                 }
 257               }
 258        ; return $ Just (loc, dec)
 259        }
 260 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
 261
 262 -- represent fundeps
 263 --
 264 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
 265 repLFunDeps fds = do fds' <- mapM repLFunDep fds
 266                      fdList <- coreList funDepTyConName fds'
 267                      return fdList
 268
 269 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
 270 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
 271                                ys' <- mapM lookupBinder ys
 272                                xs_list <- coreList nameTyConName xs'
 273                                ys_list <- coreList nameTyConName ys'
 274                                repFunDep xs_list ys_list
 275
 276 -- represent family declaration flavours
 277 --
 278 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
 279 repFamilyFlavour TypeFamily = rep2 typeFamName []
 280 repFamilyFlavour DataFamily = rep2 dataFamName []
 281
 282 -- represent associated family declarations
 283 --
 284 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
 285 repLAssocFamilys = mapM repLAssocFamily
 286   where
 287     repLAssocFamily tydecl@(L _ (TyFamily {}))
 288       = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
 289     repLAssocFamily tydecl
 290       = failWithDs msg
 291       where
 292         msg = ptext (sLit "Illegal associated declaration in class:") <+>
 293               ppr tydecl
 294
 295 -- represent associated family instances
 296 --
 297 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
 298 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
 299
 300 -- represent instance declarations
 301 --
 302 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
 303 repInstD' (L loc (InstDecl ty binds _ ats))     -- Ignore user pragmas for now
 304   = do { i <- addTyVarBinds tvs $ \_ ->
 305                 -- We must bring the type variables into scope, so their
 306                 -- occurrences don't fail, even though the binders don't
 307                 -- appear in the resulting data structure
 308                 do { cxt1 <- repContext cxt
 309                    ; inst_ty1 <- repPredTy (HsClassP cls tys)
 310                    ; ss <- mkGenSyms (collectHsBindsBinders binds)
 311                    ; binds1 <- addBinds ss (rep_binds binds)
 312                    ; ats1   <- repLAssocFamInst ats
 313                    ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
 314                    ; decls2 <- wrapNongenSyms ss decls1
 315                    -- wrapNongenSyms: do not clone the class op names!
 316                    -- They must be called 'op' etc, not 'op34'
 317                    ; repInst cxt1 inst_ty1 (decls2)
 318                    }
 319         ; return (loc, i)}
 320  where
 321    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 322
 323 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 324 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
 325  = do MkC name' <- lookupLOcc name
 326       MkC typ' <- repLTy typ
 327       MkC cc' <- repCCallConv cc
 328       MkC s' <- repSafety s
 329       cis' <- conv_cimportspec cis
 330       MkC str <- coreStringLit $ static
 331                               ++ unpackFS ch ++ " "
 332                               ++ cis'
 333       dec <- rep2 forImpDName [cc', s', str, name', typ']
 334       return (loc, dec)
 335  where
 336     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
 337     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
 338     conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
 339     conv_cimportspec CWrapper = return "wrapper"
 340     static = case cis of
 341                  CFunction (StaticTarget _ _) -> "static "
 342                  _ -> ""
 343 repForD decl = notHandled "Foreign declaration" (ppr decl)
 344
 345 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
 346 repCCallConv CCallConv = rep2 cCallName []
 347 repCCallConv StdCallConv = rep2 stdCallName []
 348 repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 349
 350 repSafety :: Safety -> DsM (Core TH.Safety)
 351 repSafety PlayRisky = rep2 unsafeName []
 352 repSafety (PlaySafe False) = rep2 safeName []
 353 repSafety (PlaySafe True) = rep2 threadsafeName []
 354
 355 ds_msg :: SDoc
 356 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 357
 358 -------------------------------------------------------
 359 --                      Constructors
 360 -------------------------------------------------------
 361
 362 repC :: LConDecl Name -> DsM (Core TH.ConQ)
 363 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
 364                    , con_details = details, con_res = ResTyH98 }))
 365   = do { con1 <- lookupLOcc con         -- See note [Binders and occurrences]
 366        ; repConstr con1 details
 367        }
 368 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
 369   = addTyVarBinds tvs $ \bndrs ->
 370       do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
 371          ; ctxt' <- repContext ctxt
 372          ; bndrs' <- coreList tyVarBndrTyConName bndrs
 373          ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
 374          }
 375 repC (L loc con_decl)           -- GADTs
 376   = putSrcSpanDs loc $
 377     notHandled "GADT declaration" (ppr con_decl)
 378
 379 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 380 repBangTy ty= do
 381   MkC s <- rep2 str []
 382   MkC t <- repLTy ty'
 383   rep2 strictTypeName [s, t]
 384   where
 385     (str, ty') = case ty of
 386                    L _ (HsBangTy _ ty) -> (isStrictName,  ty)
 387                    _                   -> (notStrictName, ty)
 388
 389 -------------------------------------------------------
 390 --                      Deriving clause
 391 -------------------------------------------------------
 392
 393 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
 394 repDerivs Nothing = coreList nameTyConName []
 395 repDerivs (Just ctxt)
 396   = do { strs <- mapM rep_deriv ctxt ;
 397          coreList nameTyConName strs }
 398   where
 399     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
 400         -- Deriving clauses must have the simple H98 form
 401     rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
 402     rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
 403
 404
 405 -------------------------------------------------------
 406 --   Signatures in a class decl, or a group of bindings
 407 -------------------------------------------------------
 408
 409 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
 410 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
 411                    return $ de_loc $ sort_by_loc locs_cores
 412
 413 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
 414         -- We silently ignore ones we don't recognise
 415 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 416                      return (concat sigs1) }
 417
 418 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 419         -- Singleton => Ok
 420         -- Empty     => Too hard, signature ignored
 421 rep_sig (L loc (TypeSig nm ty))       = rep_proto nm ty loc
 422 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
 423 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 424 rep_sig _                             = return []
 425
 426 rep_proto :: Located Name -> LHsType Name -> SrcSpan
 427           -> DsM [(SrcSpan, Core TH.DecQ)]
 428 rep_proto nm ty loc
 429   = do { nm1 <- lookupLOcc nm
 430        ; ty1 <- repLTy ty
 431        ; sig <- repProto nm1 ty1
 432        ; return [(loc, sig)]
 433        }
 434
 435 rep_inline :: Located Name
 436            -> InlinePragma      -- Never defaultInlinePragma
 437            -> SrcSpan
 438            -> DsM [(SrcSpan, Core TH.DecQ)]
 439 rep_inline nm ispec loc
 440   = do { nm1 <- lookupLOcc nm
 441        ; ispec1 <- rep_InlinePrag ispec
 442        ; pragma <- repPragInl nm1 ispec1
 443        ; return [(loc, pragma)]
 444        }
 445
 446 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
 447                -> DsM [(SrcSpan, Core TH.DecQ)]
 448 rep_specialise nm ty ispec loc
 449   = do { nm1 <- lookupLOcc nm
 450        ; ty1 <- repLTy ty
 451        ; pragma <- if isDefaultInlinePragma ispec
 452                    then repPragSpec nm1 ty1                  -- SPECIALISE
 453                    else do { ispec1 <- rep_InlinePrag ispec  -- SPECIALISE INLINE
 454                            ; repPragSpecInl nm1 ty1 ispec1 }
 455        ; return [(loc, pragma)]
 456        }
 457
 458 -- Extract all the information needed to build a TH.InlinePrag
 459 --
 460 rep_InlinePrag :: InlinePragma  -- Never defaultInlinePragma
 461                -> DsM (Core TH.InlineSpecQ)
 462 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
 463   | Nothing            <- activation1
 464     = repInlineSpecNoPhase inline1 match1
 465   | Just (flag, phase) <- activation1
 466     = repInlineSpecPhase inline1 match1 flag phase
 467   | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
 468     where
 469       match1      = coreBool (rep_RuleMatchInfo match)
 470       activation1 = rep_Activation activation
 471       inline1     = coreBool inline
 472
 473       rep_RuleMatchInfo FunLike = False
 474       rep_RuleMatchInfo ConLike = True
 475
 476       rep_Activation NeverActive          = Nothing     -- We never have NOINLINE/AlwaysActive
 477       rep_Activation AlwaysActive         = Nothing     -- or            INLINE/NeverActive
 478       rep_Activation (ActiveBefore phase) = Just (coreBool False,
 479                                                   MkC $ mkIntExprInt phase)
 480       rep_Activation (ActiveAfter phase)  = Just (coreBool True,
 481                                                   MkC $ mkIntExprInt phase)
 482
 483
 484 -------------------------------------------------------
 485 --                      Types
 486 -------------------------------------------------------
 487
 488 -- We process type variable bindings in two ways, either by generating fresh
 489 -- names or looking up existing names.  The difference is crucial for type
 490 -- families, depending on whether they are associated or not.
 491 --
 492 type ProcessTyVarBinds a =
 493          [LHsTyVarBndr Name]                           -- the binders to be added
 494       -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
 495       -> DsM (Core (TH.Q a))
 496
 497 -- gensym a list of type variables and enter them into the meta environment;
 498 -- the computations passed as the second argument is executed in that extended
 499 -- meta environment and gets the *new* names on Core-level as an argument
 500 --
 501 addTyVarBinds :: ProcessTyVarBinds a
 502 addTyVarBinds tvs m =
 503   do
 504     let names       = hsLTyVarNames tvs
 505         mkWithKinds = map repTyVarBndrWithKind tvs
 506     freshNames <- mkGenSyms names
 507     term       <- addBinds freshNames $ do
 508                     bndrs       <- mapM lookupBinder names
 509                     kindedBndrs <- zipWithM ($) mkWithKinds bndrs
 510                     m kindedBndrs
 511     wrapGenSyms freshNames term
 512
 513 -- Look up a list of type variables; the computations passed as the second
 514 -- argument gets the *new* names on Core-level as an argument
 515 --
 516 lookupTyVarBinds :: ProcessTyVarBinds a
 517 lookupTyVarBinds tvs m =
 518   do
 519     let names       = hsLTyVarNames tvs
 520         mkWithKinds = map repTyVarBndrWithKind tvs
 521     bndrs       <- mapM lookupBinder names
 522     kindedBndrs <- zipWithM ($) mkWithKinds bndrs
 523     m kindedBndrs
 524
 525 -- Produce kinded binder constructors from the Haskell tyvar binders
 526 --
 527 repTyVarBndrWithKind :: LHsTyVarBndr Name
 528                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 529 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
 530   = repPlainTV nm
 531 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
 532   = repKind ki >>= repKindedTV nm
 533
 534 -- represent a type context
 535 --
 536 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
 537 repLContext (L _ ctxt) = repContext ctxt
 538
 539 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 540 repContext ctxt = do
 541                     preds    <- mapM repLPred ctxt
 542                     predList <- coreList predQTyConName preds
 543                     repCtxt predList
 544
 545 -- represent a type predicate
 546 --
 547 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
 548 repLPred (L _ p) = repPred p
 549
 550 repPred :: HsPred Name -> DsM (Core TH.PredQ)
 551 repPred (HsClassP cls tys)
 552   = do
 553       cls1 <- lookupOcc cls
 554       tys1 <- repLTys tys
 555       tys2 <- coreList typeQTyConName tys1
 556       repClassP cls1 tys2
 557 repPred (HsEqualP tyleft tyright)
 558   = do
 559       tyleft1  <- repLTy tyleft
 560       tyright1 <- repLTy tyright
 561       repEqualP tyleft1 tyright1
 562 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 563
 564 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
 565 repPredTy (HsClassP cls tys)
 566   = do
 567       tcon <- repTy (HsTyVar cls)
 568       tys1 <- repLTys tys
 569       repTapps tcon tys1
 570 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
 571
 572 -- yield the representation of a list of types
 573 --
 574 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 575 repLTys tys = mapM repLTy tys
 576
 577 -- represent a type
 578 --
 579 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 580 repLTy (L _ ty) = repTy ty
 581
 582 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 583 repTy (HsForAllTy _ tvs ctxt ty)  =
 584   addTyVarBinds tvs $ \bndrs -> do
 585     ctxt1  <- repLContext ctxt
 586     ty1    <- repLTy ty
 587     bndrs1 <- coreList tyVarBndrTyConName bndrs
 588     repTForall bndrs1 ctxt1 ty1
 589
 590 repTy (HsTyVar n)
 591   | isTvOcc (nameOccName n) = do
 592                                 tv1 <- lookupTvOcc n
 593                                 repTvar tv1
 594   | otherwise               = do
 595                                 tc1 <- lookupOcc n
 596                                 repNamedTyCon tc1
 597 repTy (HsAppTy f a)         = do
 598                                 f1 <- repLTy f
 599                                 a1 <- repLTy a
 600                                 repTapp f1 a1
 601 repTy (HsFunTy f a)         = do
 602                                 f1   <- repLTy f
 603                                 a1   <- repLTy a
 604                                 tcon <- repArrowTyCon
 605                                 repTapps tcon [f1, a1]
 606 repTy (HsListTy t)          = do
 607                                 t1   <- repLTy t
 608                                 tcon <- repListTyCon
 609                                 repTapp tcon t1
 610 repTy (HsPArrTy t)          = do
 611                                 t1   <- repLTy t
 612                                 tcon <- repTy (HsTyVar (tyConName parrTyCon))
 613                                 repTapp tcon t1
 614 repTy (HsTupleTy _ tys)     = do
 615                                 tys1 <- repLTys tys
 616                                 tcon <- repTupleTyCon (length tys)
 617                                 repTapps tcon tys1
 618 repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 619                                    `nlHsAppTy` ty2)
 620 repTy (HsParTy t)           = repLTy t
 621 repTy (HsPredTy pred)       = repPredTy pred
 622 repTy (HsKindSig t k)       = do
 623                                 t1 <- repLTy t
 624                                 k1 <- repKind k
 625                                 repTSig t1 k1
 626 repTy (HsSpliceTy splice _ _) = repSplice splice
 627 repTy ty@(HsNumTy _)          = notHandled "Number types (for generics)" (ppr ty)
 628 repTy ty                      = notHandled "Exotic form of type" (ppr ty)
 629
 630 -- represent a kind
 631 --
 632 repKind :: Kind -> DsM (Core TH.Kind)
 633 repKind ki
 634   = do { let (kis, ki') = splitKindFunTys ki
 635        ; kis_rep <- mapM repKind kis
 636        ; ki'_rep <- repNonArrowKind ki'
 637        ; foldrM repArrowK ki'_rep kis_rep
 638        }
 639   where
 640     repNonArrowKind k | isLiftedTypeKind k = repStarK
 641                       | otherwise          = notHandled "Exotic form of kind"
 642                                                         (ppr k)
 643
 644 -----------------------------------------------------------------------------
 645 --              Splices
 646 -----------------------------------------------------------------------------
 647
 648 repSplice :: HsSplice Name -> DsM (Core a)
 649 -- See Note [How brackets and nested splices are handled] in TcSplice
 650 -- We return a CoreExpr of any old type; the context should know
 651 repSplice (HsSplice n _)
 652  = do { mb_val <- dsLookupMetaEnv n
 653        ; case mb_val of
 654            Just (Splice e) -> do { e' <- dsExpr e
 655                                  ; return (MkC e') }
 656            _ -> pprPanic "HsSplice" (ppr n) }
 657                         -- Should not happen; statically checked
 658
 659 -----------------------------------------------------------------------------
 660 --              Expressions
 661 -----------------------------------------------------------------------------
 662
 663 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
 664 repLEs es = do { es'  <- mapM repLE es ;
 665                  coreList expQTyConName es' }
 666
 667 -- FIXME: some of these panics should be converted into proper error messages
 668 --        unless we can make sure that constructs, which are plainly not
 669 --        supported in TH already lead to error messages at an earlier stage
 670 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
 671 repLE (L loc e) = putSrcSpanDs loc (repE e)
 672
 673 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 674 repE (HsVar x)            =
 675   do { mb_val <- dsLookupMetaEnv x
 676      ; case mb_val of
 677         Nothing          -> do { str <- globalVar x
 678                                ; repVarOrCon x str }
 679         Just (Bound y)   -> repVarOrCon x (coreVar y)
 680         Just (Splice e)  -> do { e' <- dsExpr e
 681                                ; return (MkC e') } }
 682 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 683
 684         -- Remember, we're desugaring renamer output here, so
 685         -- HsOverlit can definitely occur
 686 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 687 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 688 repE (HsLam (MatchGroup [m] _)) = repLambda m
 689 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 690
 691 repE (OpApp e1 op _ e2) =
 692   do { arg1 <- repLE e1;
 693        arg2 <- repLE e2;
 694        the_op <- repLE op ;
 695        repInfixApp arg1 the_op arg2 }
 696 repE (NegApp x _)        = do
 697                               a         <- repLE x
 698                               negateVar <- lookupOcc negateName >>= repVar
 699                               negateVar `repApp` a
 700 repE (HsPar x)            = repLE x
 701 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 702 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 703 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 704                                        ; ms2 <- mapM repMatchTup ms
 705                                        ; repCaseE arg (nonEmptyCoreList ms2) }
 706 repE (HsIf x y z)         = do
 707                               a <- repLE x
 708                               b <- repLE y
 709                               c <- repLE z
 710                               repCond a b c
 711 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 712                                ; e2 <- addBinds ss (repLE e)
 713                                ; z <- repLetE ds e2
 714                                ; wrapGenSyms ss z }
 715
 716 -- FIXME: I haven't got the types here right yet
 717 repE e@(HsDo ctxt sts body _)
 718  | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
 719  = do { (ss,zs) <- repLSts sts;
 720         body'   <- addBinds ss $ repLE body;
 721         ret     <- repNoBindSt body';
 722         e'      <- repDoE (nonEmptyCoreList (zs ++ [ret]));
 723         wrapGenSyms ss e' }
 724
 725  | ListComp <- ctxt
 726  = do { (ss,zs) <- repLSts sts;
 727         body'   <- addBinds ss $ repLE body;
 728         ret     <- repNoBindSt body';
 729         e'      <- repComp (nonEmptyCoreList (zs ++ [ret]));
 730         wrapGenSyms ss e' }
 731
 732   | otherwise
 733   = notHandled "mdo and [: :]" (ppr e)
 734
 735 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
 736 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
 737 repE e@(ExplicitTuple es boxed)
 738   | not (isBoxed boxed)        = notHandled "Unboxed tuples" (ppr e)
 739   | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
 740   | otherwise                  = do { xs <- repLEs [e | Present e <- es]; repTup xs }
 741
 742 repE (RecordCon c _ flds)
 743  = do { x <- lookupLOcc c;
 744         fs <- repFields flds;
 745         repRecCon x fs }
 746 repE (RecordUpd e flds _ _ _)
 747  = do { x <- repLE e;
 748         fs <- repFields flds;
 749         repRecUpd x fs }
 750
 751 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
 752 repE (ArithSeq _ aseq) =
 753   case aseq of
 754     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 755     FromThen e1 e2      -> do
 756                              ds1 <- repLE e1
 757                              ds2 <- repLE e2
 758                              repFromThen ds1 ds2
 759     FromTo   e1 e2      -> do
 760                              ds1 <- repLE e1
 761                              ds2 <- repLE e2
 762                              repFromTo ds1 ds2
 763     FromThenTo e1 e2 e3 -> do
 764                              ds1 <- repLE e1
 765                              ds2 <- repLE e2
 766                              ds3 <- repLE e3
 767                              repFromThenTo ds1 ds2 ds3
 768
 769 repE (HsSpliceE splice)  = repSplice splice
 770 repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
 771 repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
 772 repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
 773 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
 774 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
 775 repE e                   = notHandled "Expression form" (ppr e)
 776
 777 -----------------------------------------------------------------------------
 778 -- Building representations of auxillary structures like Match, Clause, Stmt,
 779
 780 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
 781 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
 782   do { ss1 <- mkGenSyms (collectPatBinders p)
 783      ; addBinds ss1 $ do {
 784      ; p1 <- repLP p
 785      ; (ss2,ds) <- repBinds wheres
 786      ; addBinds ss2 $ do {
 787      ; gs    <- repGuards guards
 788      ; match <- repMatch p1 gs ds
 789      ; wrapGenSyms (ss1++ss2) match }}}
 790 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
 791
 792 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
 793 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
 794   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 795      ; addBinds ss1 $ do {
 796        ps1 <- repLPs ps
 797      ; (ss2,ds) <- repBinds wheres
 798      ; addBinds ss2 $ do {
 799        gs <- repGuards guards
 800      ; clause <- repClause ps1 gs ds
 801      ; wrapGenSyms (ss1++ss2) clause }}}
 802
 803 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 804 repGuards [L _ (GRHS [] e)]
 805   = do {a <- repLE e; repNormal a }
 806 repGuards other
 807   = do { zs <- mapM process other;
 808      let {(xs, ys) = unzip zs};
 809          gd <- repGuarded (nonEmptyCoreList ys);
 810      wrapGenSyms (concat xs) gd }
 811   where
 812     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
 813     process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
 814            = do { x <- repLNormalGE e1 e2;
 815                   return ([], x) }
 816     process (L _ (GRHS ss rhs))
 817            = do (gs, ss') <- repLSts ss
 818                 rhs' <- addBinds gs $ repLE rhs
 819                 g <- repPatGE (nonEmptyCoreList ss') rhs'
 820                 return (gs, g)
 821
 822 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 823 repFields (HsRecFields { rec_flds = flds })
 824   = do  { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
 825         ; es <- mapM repLE (map hsRecFieldArg flds)
 826         ; fs <- zipWithM repFieldExp fnames es
 827         ; coreList fieldExpQTyConName fs }
 828
 829
 830 -----------------------------------------------------------------------------
 831 -- Representing Stmt's is tricky, especially if bound variables
 832 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 833 -- First gensym new names for every variable in any of the patterns.
 834 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 835 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 836 -- and we could reuse the original names (x and x).
 837 --
 838 -- do { x'1 <- gensym "x"
 839 --    ; x'2 <- gensym "x"
 840 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 841 --          , BindSt (pvar x'2) [| f x |]
 842 --          , NoBindSt [| g x |]
 843 --          ]
 844 --    }
 845
 846 -- The strategy is to translate a whole list of do-bindings by building a
 847 -- bigger environment, and a bigger set of meta bindings
 848 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 849 -- of the expressions within the Do
 850
 851 -----------------------------------------------------------------------------
 852 -- The helper function repSts computes the translation of each sub expression
 853 -- and a bunch of prefix bindings denoting the dynamic renaming.
 854
 855 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 856 repLSts stmts = repSts (map unLoc stmts)
 857
 858 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 859 repSts (BindStmt p e _ _ : ss) =
 860    do { e2 <- repLE e
 861       ; ss1 <- mkGenSyms (collectPatBinders p)
 862       ; addBinds ss1 $ do {
 863       ; p1 <- repLP p;
 864       ; (ss2,zs) <- repSts ss
 865       ; z <- repBindSt p1 e2
 866       ; return (ss1++ss2, z : zs) }}
 867 repSts (LetStmt bs : ss) =
 868    do { (ss1,ds) <- repBinds bs
 869       ; z <- repLetSt ds
 870       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 871       ; return (ss1++ss2, z : zs) }
 872 repSts (ExprStmt e _ _ : ss) =
 873    do { e2 <- repLE e
 874       ; z <- repNoBindSt e2
 875       ; (ss2,zs) <- repSts ss
 876       ; return (ss2, z : zs) }
 877 repSts []    = return ([],[])
 878 repSts other = notHandled "Exotic statement" (ppr other)
 879
 880
 881 -----------------------------------------------------------
 882 --                      Bindings
 883 -----------------------------------------------------------
 884
 885 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 886 repBinds EmptyLocalBinds
 887   = do  { core_list <- coreList decQTyConName []
 888         ; return ([], core_list) }
 889
 890 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
 891
 892 repBinds (HsValBinds decs)
 893  = do   { let { bndrs = collectHsValBinders decs }
 894                 -- No need to worrry about detailed scopes within
 895                 -- the binding group, because we are talking Names
 896                 -- here, so we can safely treat it as a mutually
 897                 -- recursive group
 898         ; ss        <- mkGenSyms bndrs
 899         ; prs       <- addBinds ss (rep_val_binds decs)
 900         ; core_list <- coreList decQTyConName
 901                                 (de_loc (sort_by_loc prs))
 902         ; return (ss, core_list) }
 903
 904 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 905 -- Assumes: all the binders of the binding are alrady in the meta-env
 906 rep_val_binds (ValBindsOut binds sigs)
 907  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
 908       ; core2 <- rep_sigs' sigs
 909       ; return (core1 ++ core2) }
 910 rep_val_binds (ValBindsIn _ _)
 911  = panic "rep_val_binds: ValBindsIn"
 912
 913 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 914 rep_binds binds = do { binds_w_locs <- rep_binds' binds
 915                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 916
 917 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 918 rep_binds' binds = mapM rep_bind (bagToList binds)
 919
 920 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 921 -- Assumes: all the binders of the binding are alrady in the meta-env
 922
 923 -- Note GHC treats declarations of a variable (not a pattern)
 924 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 925 -- with an empty list of patterns
 926 rep_bind (L loc (FunBind { fun_id = fn,
 927                            fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
 928  = do { (ss,wherecore) <- repBinds wheres
 929         ; guardcore <- addBinds ss (repGuards guards)
 930         ; fn'  <- lookupLBinder fn
 931         ; p    <- repPvar fn'
 932         ; ans  <- repVal p guardcore wherecore
 933         ; ans' <- wrapGenSyms ss ans
 934         ; return (loc, ans') }
 935
 936 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 937  =   do { ms1 <- mapM repClauseTup ms
 938         ; fn' <- lookupLBinder fn
 939         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 940         ; return (loc, ans) }
 941
 942 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 943  =   do { patcore <- repLP pat
 944         ; (ss,wherecore) <- repBinds wheres
 945         ; guardcore <- addBinds ss (repGuards guards)
 946         ; ans  <- repVal patcore guardcore wherecore
 947         ; ans' <- wrapGenSyms ss ans
 948         ; return (loc, ans') }
 949
 950 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
 951  =   do { v' <- lookupBinder v
 952         ; e2 <- repLE e
 953         ; x <- repNormal e2
 954         ; patcore <- repPvar v'
 955         ; empty_decls <- coreList decQTyConName []
 956         ; ans <- repVal patcore x empty_decls
 957         ; return (srcLocSpan (getSrcLoc v), ans) }
 958
 959 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
 960
 961 -----------------------------------------------------------------------------
 962 -- Since everything in a Bind is mutually recursive we need rename all
 963 -- all the variables simultaneously. For example:
 964 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 965 -- do { f'1 <- gensym "f"
 966 --    ; g'2 <- gensym "g"
 967 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 968 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 969 --      ]}
 970 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 971 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 972 -- together. As we do this we collect GenSymBinds's which represent the renamed
 973 -- variables bound by the Bindings. In order not to lose track of these
 974 -- representations we build a shadow datatype MB with the same structure as
 975 -- MonoBinds, but which has slots for the representations
 976
 977
 978 -----------------------------------------------------------------------------
 979 -- GHC allows a more general form of lambda abstraction than specified
 980 -- by Haskell 98. In particular it allows guarded lambda's like :
 981 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 982 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 983 -- (\ p1 .. pn -> exp) by causing an error.
 984
 985 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
 986 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 987  = do { let bndrs = collectPatsBinders ps ;
 988       ; ss  <- mkGenSyms bndrs
 989       ; lam <- addBinds ss (
 990                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 991       ; wrapGenSyms ss lam }
 992
 993 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
 994
 995
 996 -----------------------------------------------------------------------------
 997 --                      Patterns
 998 -- repP deals with patterns.  It assumes that we have already
 999 -- walked over the pattern(s) once to collect the binders, and
1000 -- have extended the environment.  So every pattern-bound
1001 -- variable should already appear in the environment.
1002
1003 -- Process a list of patterns
1004 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1005 repLPs ps = do { ps' <- mapM repLP ps ;
1006                  coreList patQTyConName ps' }
1007
1008 repLP :: LPat Name -> DsM (Core TH.PatQ)
1009 repLP (L _ p) = repP p
1010
1011 repP :: Pat Name -> DsM (Core TH.PatQ)
1012 repP (WildPat _)       = repPwild
1013 repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
1014 repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
1015 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
1016 repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }
1017 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1018 repP (ParPat p)        = repLP p
1019 repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
1020 repP p@(TuplePat ps boxed _)
1021   | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
1022   | otherwise           = do { qs <- repLPs ps; repPtup qs }
1023 repP (ConPatIn dc details)
1024  = do { con_str <- lookupLOcc dc
1025       ; case details of
1026          PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1027          RecCon rec   -> do { let flds = rec_flds rec
1028                             ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1029                             ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1030                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1031                             ; fps' <- coreList fieldPatQTyConName fps
1032                             ; repPrec con_str fps' }
1033          InfixCon p1 p2 -> do { p1' <- repLP p1;
1034                                 p2' <- repLP p2;
1035                                 repPinfix p1' con_str p2' }
1036    }
1037 repP (NPat l Nothing _)  = do { a <- repOverloadedLiteral l; repPlit a }
1038 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1039 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
1040         -- The problem is to do with scoped type variables.
1041         -- To implement them, we have to implement the scoping rules
1042         -- here in DsMeta, and I don't want to do that today!
1043         --       do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1044         --      repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1045         --      repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1046
1047 repP other = notHandled "Exotic pattern" (ppr other)
1048
1049 ----------------------------------------------------------
1050 -- Declaration ordering helpers
1051
1052 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1053 sort_by_loc xs = sortBy comp xs
1054     where comp x y = compare (fst x) (fst y)
1055
1056 de_loc :: [(a, b)] -> [b]
1057 de_loc = map snd
1058
1059 ----------------------------------------------------------
1060 --      The meta-environment
1061
1062 -- A name/identifier association for fresh names of locally bound entities
1063 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
1064                                 -- I.e.         (x, x_id) means
1065                                 --      let x_id = gensym "x" in ...
1066
1067 -- Generate a fresh name for a locally bound entity
1068
1069 mkGenSyms :: [Name] -> DsM [GenSymBind]
1070 -- We can use the existing name.  For example:
1071 --      [| \x_77 -> x_77 + x_77 |]
1072 -- desugars to
1073 --      do { x_77 <- genSym "x"; .... }
1074 -- We use the same x_77 in the desugared program, but with the type Bndr
1075 -- instead of Int
1076 --
1077 -- We do make it an Internal name, though (hence localiseName)
1078 --
1079 -- Nevertheless, it's monadic because we have to generate nameTy
1080 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1081                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1082
1083
1084 addBinds :: [GenSymBind] -> DsM a -> DsM a
1085 -- Add a list of fresh names for locally bound entities to the
1086 -- meta environment (which is part of the state carried around
1087 -- by the desugarer monad)
1088 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1089
1090 -- Look up a locally bound name
1091 --
1092 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1093 lookupLBinder (L _ n) = lookupBinder n
1094
1095 lookupBinder :: Name -> DsM (Core TH.Name)
1096 lookupBinder n
1097   = do { mb_val <- dsLookupMetaEnv n;
1098          case mb_val of
1099             Just (Bound x) -> return (coreVar x)
1100             _              -> failWithDs msg }
1101   where
1102     msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1103
1104 -- Look up a name that is either locally bound or a global name
1105 --
1106 --  * If it is a global name, generate the "original name" representation (ie,
1107 --   the <module>:<name> form) for the associated entity
1108 --
1109 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1110 -- Lookup an occurrence; it can't be a splice.
1111 -- Use the in-scope bindings if they exist
1112 lookupLOcc (L _ n) = lookupOcc n
1113
1114 lookupOcc :: Name -> DsM (Core TH.Name)
1115 lookupOcc n
1116   = do {  mb_val <- dsLookupMetaEnv n ;
1117           case mb_val of
1118                 Nothing         -> globalVar n
1119                 Just (Bound x)  -> return (coreVar x)
1120                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1121     }
1122
1123 lookupTvOcc :: Name -> DsM (Core TH.Name)
1124 -- Type variables can't be staged and are not lexically scoped in TH
1125 lookupTvOcc n
1126   = do {  mb_val <- dsLookupMetaEnv n ;
1127           case mb_val of
1128                 Just (Bound x)  -> return (coreVar x)
1129                 _               -> failWithDs msg
1130     }
1131   where
1132     msg = vcat  [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1133                 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1134
1135 globalVar :: Name -> DsM (Core TH.Name)
1136 -- Not bound by the meta-env
1137 -- Could be top-level; or could be local
1138 --      f x = $(g [| x |])
1139 -- Here the x will be local
1140 globalVar name
1141   | isExternalName name
1142   = do  { MkC mod <- coreStringLit name_mod
1143         ; MkC pkg <- coreStringLit name_pkg
1144         ; MkC occ <- occNameLit name
1145         ; rep2 mk_varg [pkg,mod,occ] }
1146   | otherwise
1147   = do  { MkC occ <- occNameLit name
1148         ; MkC uni <- coreIntLit (getKey (getUnique name))
1149         ; rep2 mkNameLName [occ,uni] }
1150   where
1151       mod = ASSERT( isExternalName name) nameModule name
1152       name_mod = moduleNameString (moduleName mod)
1153       name_pkg = packageIdString (modulePackageId mod)
1154       name_occ = nameOccName name
1155       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1156               | OccName.isVarOcc  name_occ = mkNameG_vName
1157               | OccName.isTcOcc   name_occ = mkNameG_tcName
1158               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
1159
1160 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
1161            -> DsM Type  -- The type
1162 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1163                           return (mkTyConApp tc []) }
1164
1165 wrapGenSyms :: [GenSymBind]
1166             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1167 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1168 --      --> bindQ (gensym nm1) (\ id1 ->
1169 --          bindQ (gensym nm2 (\ id2 ->
1170 --          y))
1171
1172 wrapGenSyms binds body@(MkC b)
1173   = do  { var_ty <- lookupType nameTyConName
1174         ; go var_ty binds }
1175   where
1176     [elt_ty] = tcTyConAppArgs (exprType b)
1177         -- b :: Q a, so we can get the type 'a' by looking at the
1178         -- argument type. NB: this relies on Q being a data/newtype,
1179         -- not a type synonym
1180
1181     go _ [] = return body
1182     go var_ty ((name,id) : binds)
1183       = do { MkC body'  <- go var_ty binds
1184            ; lit_str    <- occNameLit name
1185            ; gensym_app <- repGensym lit_str
1186            ; repBindQ var_ty elt_ty
1187                       gensym_app (MkC (Lam id body')) }
1188
1189 -- Just like wrapGenSym, but don't actually do the gensym
1190 -- Instead use the existing name:
1191 --      let x = "x" in ...
1192 -- Only used for [Decl], and for the class ops in class
1193 -- and instance decls
1194 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1195 wrapNongenSyms binds (MkC body)
1196   = do { binds' <- mapM do_one binds ;
1197          return (MkC (mkLets binds' body)) }
1198   where
1199     do_one (name,id)
1200         = do { MkC lit_str <- occNameLit name
1201              ; MkC var <- rep2 mkNameName [lit_str]
1202              ; return (NonRec id var) }
1203
1204 occNameLit :: Name -> DsM (Core String)
1205 occNameLit n = coreStringLit (occNameString (nameOccName n))
1206
1207
1208 -- %*********************************************************************
1209 -- %*                                                                   *
1210 --              Constructing code
1211 -- %*                                                                   *
1212 -- %*********************************************************************
1213
1214 -----------------------------------------------------------------------------
1215 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1216 -- we invent a new datatype which uses phantom types.
1217
1218 newtype Core a = MkC CoreExpr
1219 unC :: Core a -> CoreExpr
1220 unC (MkC x) = x
1221
1222 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1223 rep2 n xs = do { id <- dsLookupGlobalId n
1224                ; return (MkC (foldl App (Var id) xs)) }
1225
1226 -- Then we make "repConstructors" which use the phantom types for each of the
1227 -- smart constructors of the Meta.Meta datatypes.
1228
1229
1230 -- %*********************************************************************
1231 -- %*                                                                   *
1232 --              The 'smart constructors'
1233 -- %*                                                                   *
1234 -- %*********************************************************************
1235
1236 --------------- Patterns -----------------
1237 repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
1238 repPlit (MkC l) = rep2 litPName [l]
1239
1240 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1241 repPvar (MkC s) = rep2 varPName [s]
1242
1243 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1244 repPtup (MkC ps) = rep2 tupPName [ps]
1245
1246 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1247 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1248
1249 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1250 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1251
1252 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1253 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1254
1255 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1256 repPtilde (MkC p) = rep2 tildePName [p]
1257
1258 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1259 repPbang (MkC p) = rep2 bangPName [p]
1260
1261 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1262 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1263
1264 repPwild  :: DsM (Core TH.PatQ)
1265 repPwild = rep2 wildPName []
1266
1267 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1268 repPlist (MkC ps) = rep2 listPName [ps]
1269
1270 --------------- Expressions -----------------
1271 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1272 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1273                    | otherwise                  = repVar str
1274
1275 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1276 repVar (MkC s) = rep2 varEName [s]
1277
1278 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1279 repCon (MkC s) = rep2 conEName [s]
1280
1281 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1282 repLit (MkC c) = rep2 litEName [c]
1283
1284 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1285 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1286
1287 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1288 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1289
1290 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1291 repTup (MkC es) = rep2 tupEName [es]
1292
1293 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1294 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
1295
1296 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1297 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1298
1299 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1300 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1301
1302 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1303 repDoE (MkC ss) = rep2 doEName [ss]
1304
1305 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1306 repComp (MkC ss) = rep2 compEName [ss]
1307
1308 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1309 repListExp (MkC es) = rep2 listEName [es]
1310
1311 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1312 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1313
1314 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1315 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1316
1317 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1318 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1319
1320 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1321 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1322
1323 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1324 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1325
1326 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1327 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1328
1329 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1330 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1331
1332 ------------ Right hand sides (guarded expressions) ----
1333 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1334 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1335
1336 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1337 repNormal (MkC e) = rep2 normalBName [e]
1338
1339 ------------ Guards ----
1340 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1341 repLNormalGE g e = do g' <- repLE g
1342                       e' <- repLE e
1343                       repNormalGE g' e'
1344
1345 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1346 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1347
1348 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1349 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1350
1351 ------------- Stmts -------------------
1352 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1353 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1354
1355 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1356 repLetSt (MkC ds) = rep2 letSName [ds]
1357
1358 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1359 repNoBindSt (MkC e) = rep2 noBindSName [e]
1360
1361 -------------- Range (Arithmetic sequences) -----------
1362 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1363 repFrom (MkC x) = rep2 fromEName [x]
1364
1365 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1366 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1367
1368 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1369 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1370
1371 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1372 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1373
1374 ------------ Match and Clause Tuples -----------
1375 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1376 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1377
1378 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1379 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1380
1381 -------------- Dec -----------------------------
1382 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1383 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1384
1385 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1386 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1387
1388 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1389         -> Maybe (Core [TH.TypeQ])
1390         -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1391 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1392   = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1393 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1394   = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1395
1396 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1397            -> Maybe (Core [TH.TypeQ])
1398            -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1399 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1400   = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1401 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1402   = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1403
1404 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1405          -> Maybe (Core [TH.TypeQ])
1406          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1407 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1408   = rep2 tySynDName [nm, tvs, rhs]
1409 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1410   = rep2 tySynInstDName [nm, tys, rhs]
1411
1412 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1413 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1414
1415 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1416          -> Core [TH.FunDep] -> Core [TH.DecQ]
1417          -> DsM (Core TH.DecQ)
1418 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1419   = rep2 classDName [cxt, cls, tvs, fds, ds]
1420
1421 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1422 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1423
1424 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1425 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1426
1427 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1428                -> DsM (Core TH.DecQ)
1429 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1430   = rep2 pragSpecInlDName [nm, ty, ispec]
1431
1432 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1433                 -> DsM (Core TH.DecQ)
1434 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1435     = rep2 familyNoKindDName [flav, nm, tvs]
1436
1437 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1438               -> Core TH.Kind
1439               -> DsM (Core TH.DecQ)
1440 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1441     = rep2 familyKindDName [flav, nm, tvs, ki]
1442
1443 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1444 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1445   = rep2 inlineSpecNoPhaseName [inline, conlike]
1446
1447 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1448                    -> DsM (Core TH.InlineSpecQ)
1449 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1450   = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1451
1452 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1453 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1454
1455 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1456 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1457
1458 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1459 repCtxt (MkC tys) = rep2 cxtName [tys]
1460
1461 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1462 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1463
1464 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1465 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1466
1467 repConstr :: Core TH.Name -> HsConDeclDetails Name
1468           -> DsM (Core TH.ConQ)
1469 repConstr con (PrefixCon ps)
1470     = do arg_tys  <- mapM repBangTy ps
1471          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1472          rep2 normalCName [unC con, unC arg_tys1]
1473 repConstr con (RecCon ips)
1474     = do arg_vs   <- mapM lookupLOcc (map cd_fld_name ips)
1475          arg_tys  <- mapM repBangTy (map cd_fld_type ips)
1476          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1477                               arg_vs arg_tys
1478          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1479          rep2 recCName [unC con, unC arg_vtys']
1480 repConstr con (InfixCon st1 st2)
1481     = do arg1 <- repBangTy st1
1482          arg2 <- repBangTy st2
1483          rep2 infixCName [unC arg1, unC con, unC arg2]
1484
1485 ------------ Types -------------------
1486
1487 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1488            -> DsM (Core TH.TypeQ)
1489 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1490     = rep2 forallTName [tvars, ctxt, ty]
1491
1492 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1493 repTvar (MkC s) = rep2 varTName [s]
1494
1495 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1496 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1497
1498 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1499 repTapps f []     = return f
1500 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1501
1502 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1503 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1504
1505 --------- Type constructors --------------
1506
1507 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1508 repNamedTyCon (MkC s) = rep2 conTName [s]
1509
1510 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1511 -- Note: not Core Int; it's easier to be direct here
1512 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1513
1514 repArrowTyCon :: DsM (Core TH.TypeQ)
1515 repArrowTyCon = rep2 arrowTName []
1516
1517 repListTyCon :: DsM (Core TH.TypeQ)
1518 repListTyCon = rep2 listTName []
1519
1520 ------------ Kinds -------------------
1521
1522 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1523 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1524
1525 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1526 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1527
1528 repStarK :: DsM (Core TH.Kind)
1529 repStarK = rep2 starKName []
1530
1531 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1532 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1533
1534 ----------------------------------------------------------
1535 --              Literals
1536
1537 repLiteral :: HsLit -> DsM (Core TH.Lit)
1538 repLiteral lit
1539   = do lit' <- case lit of
1540                    HsIntPrim i    -> mk_integer i
1541                    HsWordPrim w   -> mk_integer w
1542                    HsInt i        -> mk_integer i
1543                    HsFloatPrim r  -> mk_rational r
1544                    HsDoublePrim r -> mk_rational r
1545                    _ -> return lit
1546        lit_expr <- dsLit lit'
1547        case mb_lit_name of
1548           Just lit_name -> rep2 lit_name [lit_expr]
1549           Nothing -> notHandled "Exotic literal" (ppr lit)
1550   where
1551     mb_lit_name = case lit of
1552                  HsInteger _ _  -> Just integerLName
1553                  HsInt     _    -> Just integerLName
1554                  HsIntPrim _    -> Just intPrimLName
1555                  HsWordPrim _   -> Just wordPrimLName
1556                  HsFloatPrim _  -> Just floatPrimLName
1557                  HsDoublePrim _ -> Just doublePrimLName
1558                  HsChar _       -> Just charLName
1559                  HsString _     -> Just stringLName
1560                  HsRat _ _      -> Just rationalLName
1561                  _              -> Nothing
1562
1563 mk_integer :: Integer -> DsM HsLit
1564 mk_integer  i = do integer_ty <- lookupType integerTyConName
1565                    return $ HsInteger i integer_ty
1566 mk_rational :: Rational -> DsM HsLit
1567 mk_rational r = do rat_ty <- lookupType rationalTyConName
1568                    return $ HsRat r rat_ty
1569 mk_string :: FastString -> DsM HsLit
1570 mk_string s = return $ HsString s
1571
1572 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1573 repOverloadedLiteral (OverLit { ol_val = val})
1574   = do { lit <- mk_lit val; repLiteral lit }
1575         -- The type Rational will be in the environment, becuase
1576         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1577         -- and rationalL is sucked in when any TH stuff is used
1578
1579 mk_lit :: OverLitVal -> DsM HsLit
1580 mk_lit (HsIntegral i)   = mk_integer  i
1581 mk_lit (HsFractional f) = mk_rational f
1582 mk_lit (HsIsString s)   = mk_string   s
1583
1584 --------------- Miscellaneous -------------------
1585
1586 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1587 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1588
1589 repBindQ :: Type -> Type        -- a and b
1590          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1591 repBindQ ty_a ty_b (MkC x) (MkC y)
1592   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1593
1594 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1595 repSequenceQ ty_a (MkC list)
1596   = rep2 sequenceQName [Type ty_a, list]
1597
1598 ------------ Lists and Tuples -------------------
1599 -- turn a list of patterns into a single pattern matching a list
1600
1601 coreList :: Name        -- Of the TyCon of the element type
1602          -> [Core a] -> DsM (Core [a])
1603 coreList tc_name es
1604   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1605
1606 coreList' :: Type       -- The element type
1607           -> [Core a] -> Core [a]
1608 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1609
1610 nonEmptyCoreList :: [Core a] -> Core [a]
1611   -- The list must be non-empty so we can get the element type
1612   -- Otherwise use coreList
1613 nonEmptyCoreList []           = panic "coreList: empty argument"
1614 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1615
1616 coreStringLit :: String -> DsM (Core String)
1617 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1618
1619 ------------ Bool, Literals & Variables -------------------
1620
1621 coreBool :: Bool -> Core Bool
1622 coreBool False = MkC $ mkConApp falseDataCon []
1623 coreBool True  = MkC $ mkConApp trueDataCon  []
1624
1625 coreIntLit :: Int -> DsM (Core Int)
1626 coreIntLit i = return (MkC (mkIntExprInt i))
1627
1628 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1629 coreVar id = MkC (Var id)
1630
1631 ----------------- Failure -----------------------
1632 notHandled :: String -> SDoc -> DsM a
1633 notHandled what doc = failWithDs msg
1634   where
1635     msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1636              2 doc
1637
1638
1639 -- %************************************************************************
1640 -- %*                                                                   *
1641 --              The known-key names for Template Haskell
1642 -- %*                                                                   *
1643 -- %************************************************************************
1644
1645 -- To add a name, do three things
1646 --
1647 --  1) Allocate a key
1648 --  2) Make a "Name"
1649 --  3) Add the name to knownKeyNames
1650
1651 templateHaskellNames :: [Name]
1652 -- The names that are implicitly mentioned by ``bracket''
1653 -- Should stay in sync with the import list of DsMeta
1654
1655 templateHaskellNames = [
1656     returnQName, bindQName, sequenceQName, newNameName, liftName,
1657     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1658
1659     -- Lit
1660     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1661     floatPrimLName, doublePrimLName, rationalLName,
1662     -- Pat
1663     litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1664     asPName, wildPName, recPName, listPName, sigPName,
1665     -- FieldPat
1666     fieldPatName,
1667     -- Match
1668     matchName,
1669     -- Clause
1670     clauseName,
1671     -- Exp
1672     varEName, conEName, litEName, appEName, infixEName,
1673     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1674     condEName, letEName, caseEName, doEName, compEName,
1675     fromEName, fromThenEName, fromToEName, fromThenToEName,
1676     listEName, sigEName, recConEName, recUpdEName,
1677     -- FieldExp
1678     fieldExpName,
1679     -- Body
1680     guardedBName, normalBName,
1681     -- Guard
1682     normalGEName, patGEName,
1683     -- Stmt
1684     bindSName, letSName, noBindSName, parSName,
1685     -- Dec
1686     funDName, valDName, dataDName, newtypeDName, tySynDName,
1687     classDName, instanceDName, sigDName, forImpDName,
1688     pragInlDName, pragSpecDName, pragSpecInlDName,
1689     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1690     tySynInstDName,
1691     -- Cxt
1692     cxtName,
1693     -- Pred
1694     classPName, equalPName,
1695     -- Strict
1696     isStrictName, notStrictName,
1697     -- Con
1698     normalCName, recCName, infixCName, forallCName,
1699     -- StrictType
1700     strictTypeName,
1701     -- VarStrictType
1702     varStrictTypeName,
1703     -- Type
1704     forallTName, varTName, conTName, appTName,
1705     tupleTName, arrowTName, listTName, sigTName,
1706     -- TyVarBndr
1707     plainTVName, kindedTVName,
1708     -- Kind
1709     starKName, arrowKName,
1710     -- Callconv
1711     cCallName, stdCallName,
1712     -- Safety
1713     unsafeName,
1714     safeName,
1715     threadsafeName,
1716     -- InlineSpec
1717     inlineSpecNoPhaseName, inlineSpecPhaseName,
1718     -- FunDep
1719     funDepName,
1720     -- FamFlavour
1721     typeFamName, dataFamName,
1722
1723     -- And the tycons
1724     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1725     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1726     stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1727     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1728     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1729     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1730     predQTyConName, decsQTyConName,
1731
1732     -- Quasiquoting
1733     quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1734
1735 thSyn, thLib, qqLib :: Module
1736 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1737 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1738 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1739
1740 mkTHModule :: FastString -> Module
1741 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1742
1743 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1744 libFun = mk_known_key_name OccName.varName thLib
1745 libTc  = mk_known_key_name OccName.tcName  thLib
1746 thFun  = mk_known_key_name OccName.varName thSyn
1747 thTc   = mk_known_key_name OccName.tcName  thSyn
1748 qqFun  = mk_known_key_name OccName.varName qqLib
1749
1750 -------------------- TH.Syntax -----------------------
1751 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1752     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1753     tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1754     predTyConName :: Name
1755 qTyConName        = thTc (fsLit "Q")            qTyConKey
1756 nameTyConName     = thTc (fsLit "Name")         nameTyConKey
1757 fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey
1758 patTyConName      = thTc (fsLit "Pat")          patTyConKey
1759 fieldPatTyConName = thTc (fsLit "FieldPat")     fieldPatTyConKey
1760 expTyConName      = thTc (fsLit "Exp")          expTyConKey
1761 decTyConName      = thTc (fsLit "Dec")          decTyConKey
1762 typeTyConName     = thTc (fsLit "Type")         typeTyConKey
1763 tyVarBndrTyConName= thTc (fsLit "TyVarBndr")    tyVarBndrTyConKey
1764 matchTyConName    = thTc (fsLit "Match")        matchTyConKey
1765 clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey
1766 funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey
1767 predTyConName     = thTc (fsLit "Pred")         predTyConKey
1768
1769 returnQName, bindQName, sequenceQName, newNameName, liftName,
1770     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1771     mkNameLName, liftStringName :: Name
1772 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
1773 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
1774 sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
1775 newNameName    = thFun (fsLit "newName")   newNameIdKey
1776 liftName       = thFun (fsLit "lift")      liftIdKey
1777 liftStringName = thFun (fsLit "liftString")  liftStringIdKey
1778 mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
1779 mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
1780 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
1781 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1782 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
1783
1784
1785 -------------------- TH.Lib -----------------------
1786 -- data Lit = ...
1787 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1788     floatPrimLName, doublePrimLName, rationalLName :: Name
1789 charLName       = libFun (fsLit "charL")       charLIdKey
1790 stringLName     = libFun (fsLit "stringL")     stringLIdKey
1791 integerLName    = libFun (fsLit "integerL")    integerLIdKey
1792 intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
1793 wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
1794 floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
1795 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1796 rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
1797
1798 -- data Pat = ...
1799 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1800     asPName, wildPName, recPName, listPName, sigPName :: Name
1801 litPName   = libFun (fsLit "litP")   litPIdKey
1802 varPName   = libFun (fsLit "varP")   varPIdKey
1803 tupPName   = libFun (fsLit "tupP")   tupPIdKey
1804 conPName   = libFun (fsLit "conP")   conPIdKey
1805 infixPName = libFun (fsLit "infixP") infixPIdKey
1806 tildePName = libFun (fsLit "tildeP") tildePIdKey
1807 bangPName  = libFun (fsLit "bangP")  bangPIdKey
1808 asPName    = libFun (fsLit "asP")    asPIdKey
1809 wildPName  = libFun (fsLit "wildP")  wildPIdKey
1810 recPName   = libFun (fsLit "recP")   recPIdKey
1811 listPName  = libFun (fsLit "listP")  listPIdKey
1812 sigPName   = libFun (fsLit "sigP")   sigPIdKey
1813
1814 -- type FieldPat = ...
1815 fieldPatName :: Name
1816 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1817
1818 -- data Match = ...
1819 matchName :: Name
1820 matchName = libFun (fsLit "match") matchIdKey
1821
1822 -- data Clause = ...
1823 clauseName :: Name
1824 clauseName = libFun (fsLit "clause") clauseIdKey
1825
1826 -- data Exp = ...
1827 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1828     sectionLName, sectionRName, lamEName, tupEName, condEName,
1829     letEName, caseEName, doEName, compEName :: Name
1830 varEName        = libFun (fsLit "varE")        varEIdKey
1831 conEName        = libFun (fsLit "conE")        conEIdKey
1832 litEName        = libFun (fsLit "litE")        litEIdKey
1833 appEName        = libFun (fsLit "appE")        appEIdKey
1834 infixEName      = libFun (fsLit "infixE")      infixEIdKey
1835 infixAppName    = libFun (fsLit "infixApp")    infixAppIdKey
1836 sectionLName    = libFun (fsLit "sectionL")    sectionLIdKey
1837 sectionRName    = libFun (fsLit "sectionR")    sectionRIdKey
1838 lamEName        = libFun (fsLit "lamE")        lamEIdKey
1839 tupEName        = libFun (fsLit "tupE")        tupEIdKey
1840 condEName       = libFun (fsLit "condE")       condEIdKey
1841 letEName        = libFun (fsLit "letE")        letEIdKey
1842 caseEName       = libFun (fsLit "caseE")       caseEIdKey
1843 doEName         = libFun (fsLit "doE")         doEIdKey
1844 compEName       = libFun (fsLit "compE")       compEIdKey
1845 -- ArithSeq skips a level
1846 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1847 fromEName       = libFun (fsLit "fromE")       fromEIdKey
1848 fromThenEName   = libFun (fsLit "fromThenE")   fromThenEIdKey
1849 fromToEName     = libFun (fsLit "fromToE")     fromToEIdKey
1850 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1851 -- end ArithSeq
1852 listEName, sigEName, recConEName, recUpdEName :: Name
1853 listEName       = libFun (fsLit "listE")       listEIdKey
1854 sigEName        = libFun (fsLit "sigE")        sigEIdKey
1855 recConEName     = libFun (fsLit "recConE")     recConEIdKey
1856 recUpdEName     = libFun (fsLit "recUpdE")     recUpdEIdKey
1857
1858 -- type FieldExp = ...
1859 fieldExpName :: Name
1860 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1861
1862 -- data Body = ...
1863 guardedBName, normalBName :: Name
1864 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1865 normalBName  = libFun (fsLit "normalB")  normalBIdKey
1866
1867 -- data Guard = ...
1868 normalGEName, patGEName :: Name
1869 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1870 patGEName    = libFun (fsLit "patGE")    patGEIdKey
1871
1872 -- data Stmt = ...
1873 bindSName, letSName, noBindSName, parSName :: Name
1874 bindSName   = libFun (fsLit "bindS")   bindSIdKey
1875 letSName    = libFun (fsLit "letS")    letSIdKey
1876 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1877 parSName    = libFun (fsLit "parS")    parSIdKey
1878
1879 -- data Dec = ...
1880 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1881     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1882     pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1883     newtypeInstDName, tySynInstDName :: Name
1884 funDName         = libFun (fsLit "funD")         funDIdKey
1885 valDName         = libFun (fsLit "valD")         valDIdKey
1886 dataDName        = libFun (fsLit "dataD")        dataDIdKey
1887 newtypeDName     = libFun (fsLit "newtypeD")     newtypeDIdKey
1888 tySynDName       = libFun (fsLit "tySynD")       tySynDIdKey
1889 classDName       = libFun (fsLit "classD")       classDIdKey
1890 instanceDName    = libFun (fsLit "instanceD")    instanceDIdKey
1891 sigDName         = libFun (fsLit "sigD")         sigDIdKey
1892 forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
1893 pragInlDName     = libFun (fsLit "pragInlD")     pragInlDIdKey
1894 pragSpecDName    = libFun (fsLit "pragSpecD")    pragSpecDIdKey
1895 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1896 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1897 familyKindDName  = libFun (fsLit "familyKindD")  familyKindDIdKey
1898 dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
1899 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1900 tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
1901
1902 -- type Ctxt = ...
1903 cxtName :: Name
1904 cxtName = libFun (fsLit "cxt") cxtIdKey
1905
1906 -- data Pred = ...
1907 classPName, equalPName :: Name
1908 classPName = libFun (fsLit "classP") classPIdKey
1909 equalPName = libFun (fsLit "equalP") equalPIdKey
1910
1911 -- data Strict = ...
1912 isStrictName, notStrictName :: Name
1913 isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
1914 notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
1915
1916 -- data Con = ...
1917 normalCName, recCName, infixCName, forallCName :: Name
1918 normalCName = libFun (fsLit "normalC") normalCIdKey
1919 recCName    = libFun (fsLit "recC")    recCIdKey
1920 infixCName  = libFun (fsLit "infixC")  infixCIdKey
1921 forallCName  = libFun (fsLit "forallC")  forallCIdKey
1922
1923 -- type StrictType = ...
1924 strictTypeName :: Name
1925 strictTypeName    = libFun  (fsLit "strictType")    strictTKey
1926
1927 -- type VarStrictType = ...
1928 varStrictTypeName :: Name
1929 varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
1930
1931 -- data Type = ...
1932 forallTName, varTName, conTName, tupleTName, arrowTName,
1933     listTName, appTName, sigTName :: Name
1934 forallTName = libFun (fsLit "forallT") forallTIdKey
1935 varTName    = libFun (fsLit "varT")    varTIdKey
1936 conTName    = libFun (fsLit "conT")    conTIdKey
1937 tupleTName  = libFun (fsLit "tupleT")  tupleTIdKey
1938 arrowTName  = libFun (fsLit "arrowT")  arrowTIdKey
1939 listTName   = libFun (fsLit "listT")   listTIdKey
1940 appTName    = libFun (fsLit "appT")    appTIdKey
1941 sigTName    = libFun (fsLit "sigT")    sigTIdKey
1942
1943 -- data TyVarBndr = ...
1944 plainTVName, kindedTVName :: Name
1945 plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
1946 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1947
1948 -- data Kind = ...
1949 starKName, arrowKName :: Name
1950 starKName  = libFun (fsLit "starK")   starKIdKey
1951 arrowKName = libFun (fsLit "arrowK")  arrowKIdKey
1952
1953 -- data Callconv = ...
1954 cCallName, stdCallName :: Name
1955 cCallName = libFun (fsLit "cCall") cCallIdKey
1956 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1957
1958 -- data Safety = ...
1959 unsafeName, safeName, threadsafeName :: Name
1960 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
1961 safeName       = libFun (fsLit "safe") safeIdKey
1962 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1963
1964 -- data InlineSpec = ...
1965 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1966 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1967 inlineSpecPhaseName   = libFun (fsLit "inlineSpecPhase")   inlineSpecPhaseIdKey
1968
1969 -- data FunDep = ...
1970 funDepName :: Name
1971 funDepName     = libFun (fsLit "funDep") funDepIdKey
1972
1973 -- data FamFlavour = ...
1974 typeFamName, dataFamName :: Name
1975 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1976 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1977
1978 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1979     decQTyConName, conQTyConName, strictTypeQTyConName,
1980     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1981     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
1982 matchQTyConName         = libTc (fsLit "MatchQ")        matchQTyConKey
1983 clauseQTyConName        = libTc (fsLit "ClauseQ")       clauseQTyConKey
1984 expQTyConName           = libTc (fsLit "ExpQ")          expQTyConKey
1985 stmtQTyConName          = libTc (fsLit "StmtQ")         stmtQTyConKey
1986 decQTyConName           = libTc (fsLit "DecQ")          decQTyConKey
1987 decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
1988 conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
1989 strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
1990 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1991 typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
1992 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
1993 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
1994 fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
1995 predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
1996
1997 -- quasiquoting
1998 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
1999 quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey
2000 quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
2001 quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
2002 quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
2003
2004 -- TyConUniques available: 100-129
2005 -- Check in PrelNames if you want to change this
2006
2007 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2008     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2009     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2010     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2011     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2012     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2013     predQTyConKey, decsQTyConKey :: Unique
2014 expTyConKey             = mkPreludeTyConUnique 100
2015 matchTyConKey           = mkPreludeTyConUnique 101
2016 clauseTyConKey          = mkPreludeTyConUnique 102
2017 qTyConKey               = mkPreludeTyConUnique 103
2018 expQTyConKey            = mkPreludeTyConUnique 104
2019 decQTyConKey            = mkPreludeTyConUnique 105
2020 patTyConKey             = mkPreludeTyConUnique 106
2021 matchQTyConKey          = mkPreludeTyConUnique 107
2022 clauseQTyConKey         = mkPreludeTyConUnique 108
2023 stmtQTyConKey           = mkPreludeTyConUnique 109
2024 conQTyConKey            = mkPreludeTyConUnique 110
2025 typeQTyConKey           = mkPreludeTyConUnique 111
2026 typeTyConKey            = mkPreludeTyConUnique 112
2027 decTyConKey             = mkPreludeTyConUnique 113
2028 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
2029 strictTypeQTyConKey     = mkPreludeTyConUnique 115
2030 fieldExpTyConKey        = mkPreludeTyConUnique 116
2031 fieldPatTyConKey        = mkPreludeTyConUnique 117
2032 nameTyConKey            = mkPreludeTyConUnique 118
2033 patQTyConKey            = mkPreludeTyConUnique 119
2034 fieldPatQTyConKey       = mkPreludeTyConUnique 120
2035 fieldExpQTyConKey       = mkPreludeTyConUnique 121
2036 funDepTyConKey          = mkPreludeTyConUnique 122
2037 predTyConKey            = mkPreludeTyConUnique 123
2038 predQTyConKey           = mkPreludeTyConUnique 124
2039 tyVarBndrTyConKey       = mkPreludeTyConUnique 125
2040 decsQTyConKey           = mkPreludeTyConUnique 126
2041
2042 -- IdUniques available: 200-399
2043 -- If you want to change this, make sure you check in PrelNames
2044
2045 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2046     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2047     mkNameLIdKey :: Unique
2048 returnQIdKey        = mkPreludeMiscIdUnique 200
2049 bindQIdKey          = mkPreludeMiscIdUnique 201
2050 sequenceQIdKey      = mkPreludeMiscIdUnique 202
2051 liftIdKey           = mkPreludeMiscIdUnique 203
2052 newNameIdKey         = mkPreludeMiscIdUnique 204
2053 mkNameIdKey          = mkPreludeMiscIdUnique 205
2054 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
2055 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
2056 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
2057 mkNameLIdKey         = mkPreludeMiscIdUnique 209
2058
2059
2060 -- data Lit = ...
2061 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2062     floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2063 charLIdKey        = mkPreludeMiscIdUnique 210
2064 stringLIdKey      = mkPreludeMiscIdUnique 211
2065 integerLIdKey     = mkPreludeMiscIdUnique 212
2066 intPrimLIdKey     = mkPreludeMiscIdUnique 213
2067 wordPrimLIdKey    = mkPreludeMiscIdUnique 214
2068 floatPrimLIdKey   = mkPreludeMiscIdUnique 215
2069 doublePrimLIdKey  = mkPreludeMiscIdUnique 216
2070 rationalLIdKey    = mkPreludeMiscIdUnique 217
2071
2072 liftStringIdKey :: Unique
2073 liftStringIdKey     = mkPreludeMiscIdUnique 218
2074
2075 -- data Pat = ...
2076 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2077     asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2078 litPIdKey         = mkPreludeMiscIdUnique 220
2079 varPIdKey         = mkPreludeMiscIdUnique 221
2080 tupPIdKey         = mkPreludeMiscIdUnique 222
2081 conPIdKey         = mkPreludeMiscIdUnique 223
2082 infixPIdKey       = mkPreludeMiscIdUnique 312
2083 tildePIdKey       = mkPreludeMiscIdUnique 224
2084 bangPIdKey        = mkPreludeMiscIdUnique 359
2085 asPIdKey          = mkPreludeMiscIdUnique 225
2086 wildPIdKey        = mkPreludeMiscIdUnique 226
2087 recPIdKey         = mkPreludeMiscIdUnique 227
2088 listPIdKey        = mkPreludeMiscIdUnique 228
2089 sigPIdKey         = mkPreludeMiscIdUnique 229
2090
2091 -- type FieldPat = ...
2092 fieldPatIdKey :: Unique
2093 fieldPatIdKey       = mkPreludeMiscIdUnique 230
2094
2095 -- data Match = ...
2096 matchIdKey :: Unique
2097 matchIdKey          = mkPreludeMiscIdUnique 231
2098
2099 -- data Clause = ...
2100 clauseIdKey :: Unique
2101 clauseIdKey         = mkPreludeMiscIdUnique 232
2102
2103
2104 -- data Exp = ...
2105 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2106     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2107     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2108     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2109     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2110 varEIdKey         = mkPreludeMiscIdUnique 240
2111 conEIdKey         = mkPreludeMiscIdUnique 241
2112 litEIdKey         = mkPreludeMiscIdUnique 242
2113 appEIdKey         = mkPreludeMiscIdUnique 243
2114 infixEIdKey       = mkPreludeMiscIdUnique 244
2115 infixAppIdKey     = mkPreludeMiscIdUnique 245
2116 sectionLIdKey     = mkPreludeMiscIdUnique 246
2117 sectionRIdKey     = mkPreludeMiscIdUnique 247
2118 lamEIdKey         = mkPreludeMiscIdUnique 248
2119 tupEIdKey         = mkPreludeMiscIdUnique 249
2120 condEIdKey        = mkPreludeMiscIdUnique 250
2121 letEIdKey         = mkPreludeMiscIdUnique 251
2122 caseEIdKey        = mkPreludeMiscIdUnique 252
2123 doEIdKey          = mkPreludeMiscIdUnique 253
2124 compEIdKey        = mkPreludeMiscIdUnique 254
2125 fromEIdKey        = mkPreludeMiscIdUnique 255
2126 fromThenEIdKey    = mkPreludeMiscIdUnique 256
2127 fromToEIdKey      = mkPreludeMiscIdUnique 257
2128 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
2129 listEIdKey        = mkPreludeMiscIdUnique 259
2130 sigEIdKey         = mkPreludeMiscIdUnique 260
2131 recConEIdKey      = mkPreludeMiscIdUnique 261
2132 recUpdEIdKey      = mkPreludeMiscIdUnique 262
2133
2134 -- type FieldExp = ...
2135 fieldExpIdKey :: Unique
2136 fieldExpIdKey       = mkPreludeMiscIdUnique 265
2137
2138 -- data Body = ...
2139 guardedBIdKey, normalBIdKey :: Unique
2140 guardedBIdKey     = mkPreludeMiscIdUnique 266
2141 normalBIdKey      = mkPreludeMiscIdUnique 267
2142
2143 -- data Guard = ...
2144 normalGEIdKey, patGEIdKey :: Unique
2145 normalGEIdKey     = mkPreludeMiscIdUnique 310
2146 patGEIdKey        = mkPreludeMiscIdUnique 311
2147
2148 -- data Stmt = ...
2149 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2150 bindSIdKey       = mkPreludeMiscIdUnique 268
2151 letSIdKey        = mkPreludeMiscIdUnique 269
2152 noBindSIdKey     = mkPreludeMiscIdUnique 270
2153 parSIdKey        = mkPreludeMiscIdUnique 271
2154
2155 -- data Dec = ...
2156 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2157     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2158     pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2159     dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2160 funDIdKey         = mkPreludeMiscIdUnique 272
2161 valDIdKey         = mkPreludeMiscIdUnique 273
2162 dataDIdKey        = mkPreludeMiscIdUnique 274
2163 newtypeDIdKey     = mkPreludeMiscIdUnique 275
2164 tySynDIdKey       = mkPreludeMiscIdUnique 276
2165 classDIdKey       = mkPreludeMiscIdUnique 277
2166 instanceDIdKey    = mkPreludeMiscIdUnique 278
2167 sigDIdKey         = mkPreludeMiscIdUnique 279
2168 forImpDIdKey      = mkPreludeMiscIdUnique 297
2169 pragInlDIdKey     = mkPreludeMiscIdUnique 348
2170 pragSpecDIdKey    = mkPreludeMiscIdUnique 349
2171 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2172 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2173 familyKindDIdKey  = mkPreludeMiscIdUnique 353
2174 dataInstDIdKey    = mkPreludeMiscIdUnique 341
2175 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2176 tySynInstDIdKey   = mkPreludeMiscIdUnique 343
2177
2178 -- type Cxt = ...
2179 cxtIdKey :: Unique
2180 cxtIdKey            = mkPreludeMiscIdUnique 280
2181
2182 -- data Pred = ...
2183 classPIdKey, equalPIdKey :: Unique
2184 classPIdKey         = mkPreludeMiscIdUnique 346
2185 equalPIdKey         = mkPreludeMiscIdUnique 347
2186
2187 -- data Strict = ...
2188 isStrictKey, notStrictKey :: Unique
2189 isStrictKey         = mkPreludeMiscIdUnique 281
2190 notStrictKey        = mkPreludeMiscIdUnique 282
2191
2192 -- data Con = ...
2193 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2194 normalCIdKey      = mkPreludeMiscIdUnique 283
2195 recCIdKey         = mkPreludeMiscIdUnique 284
2196 infixCIdKey       = mkPreludeMiscIdUnique 285
2197 forallCIdKey      = mkPreludeMiscIdUnique 288
2198
2199 -- type StrictType = ...
2200 strictTKey :: Unique
2201 strictTKey        = mkPreludeMiscIdUnique 286
2202
2203 -- type VarStrictType = ...
2204 varStrictTKey :: Unique
2205 varStrictTKey     = mkPreludeMiscIdUnique 287
2206
2207 -- data Type = ...
2208 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2209     listTIdKey, appTIdKey, sigTIdKey :: Unique
2210 forallTIdKey      = mkPreludeMiscIdUnique 290
2211 varTIdKey         = mkPreludeMiscIdUnique 291
2212 conTIdKey         = mkPreludeMiscIdUnique 292
2213 tupleTIdKey       = mkPreludeMiscIdUnique 294
2214 arrowTIdKey       = mkPreludeMiscIdUnique 295
2215 listTIdKey        = mkPreludeMiscIdUnique 296
2216 appTIdKey         = mkPreludeMiscIdUnique 293
2217 sigTIdKey         = mkPreludeMiscIdUnique 358
2218
2219 -- data TyVarBndr = ...
2220 plainTVIdKey, kindedTVIdKey :: Unique
2221 plainTVIdKey      = mkPreludeMiscIdUnique 354
2222 kindedTVIdKey     = mkPreludeMiscIdUnique 355
2223
2224 -- data Kind = ...
2225 starKIdKey, arrowKIdKey :: Unique
2226 starKIdKey        = mkPreludeMiscIdUnique 356
2227 arrowKIdKey       = mkPreludeMiscIdUnique 357
2228
2229 -- data Callconv = ...
2230 cCallIdKey, stdCallIdKey :: Unique
2231 cCallIdKey      = mkPreludeMiscIdUnique 300
2232 stdCallIdKey    = mkPreludeMiscIdUnique 301
2233
2234 -- data Safety = ...
2235 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2236 unsafeIdKey     = mkPreludeMiscIdUnique 305
2237 safeIdKey       = mkPreludeMiscIdUnique 306
2238 threadsafeIdKey = mkPreludeMiscIdUnique 307
2239
2240 -- data InlineSpec =
2241 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2242 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2243 inlineSpecPhaseIdKey   = mkPreludeMiscIdUnique 351
2244
2245 -- data FunDep = ...
2246 funDepIdKey :: Unique
2247 funDepIdKey = mkPreludeMiscIdUnique 320
2248
2249 -- data FamFlavour = ...
2250 typeFamIdKey, dataFamIdKey :: Unique
2251 typeFamIdKey = mkPreludeMiscIdUnique 344
2252 dataFamIdKey = mkPreludeMiscIdUnique 345
2253
2254 -- quasiquoting
2255 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2256 quoteExpKey  = mkPreludeMiscIdUnique 321
2257 quotePatKey  = mkPreludeMiscIdUnique 322
2258 quoteDecKey  = mkPreludeMiscIdUnique 323
2259 quoteTypeKey = mkPreludeMiscIdUnique 324