compiler/deSugar/DsMeta.hs

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