ghc/compiler/deSugar/DsMeta.hs

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