ghc/compiler/deSugar/DsMeta.hs

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