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