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