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