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