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