ghc/compiler/deSugar/DsMeta.hs

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