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