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