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 ctxt sts _ ty loc)
 391   | isComprCtxt ctxt      = do { (ss,zs) <- repSts sts;
 392                                  e       <- repDoE (nonEmptyCoreList zs);
 393                                  wrapGenSyns expTyConName ss e }
 394   | otherwise             =
 395     panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 396   where
 397     isComprCtxt ListComp = True
 398     isComprCtxt DoExpr   = True
 399     isComprCtxt _        = False
 400 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
 401 repE (ExplicitPArr ty es) =
 402   panic "DsMeta.repE: No explicit parallel arrays yet"
 403 repE (ExplicitTuple es boxed)
 404   | isBoxed boxed         = do { xs <- repEs es; repTup xs }
 405   | otherwise             = panic "DsMeta.repE: Can't represent unboxed tuples"
 406 repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
 407 repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
 408
 409 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
 410 repE (ArithSeqIn aseq) =
 411   case aseq of
 412     From e              -> do { ds1 <- repE e; repFrom ds1 }
 413     FromThen e1 e2      -> do
 414                              ds1 <- repE e1
 415                              ds2 <- repE e2
 416                              repFromThen ds1 ds2
 417     FromTo   e1 e2      -> do
 418                              ds1 <- repE e1
 419                              ds2 <- repE e2
 420                              repFromTo ds1 ds2
 421     FromThenTo e1 e2 e3 -> do
 422                              ds1 <- repE e1
 423                              ds2 <- repE e2
 424                              ds3 <- repE e3
 425                              repFromThenTo ds1 ds2 ds3
 426 repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
 427 repE (HsCCall _ _ _ _ _)  = panic "DsMeta.repE: Can't represent __ccall__"
 428 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 429 repE (HsBracketOut _ _)   =
 430   panic "DsMeta.repE: Can't represent Oxford brackets"
 431 repE (HsSplice n e loc)   = do { mb_val <- dsLookupMetaEnv n
 432                                ; case mb_val of
 433                                  Just (Splice e) -> do { e' <- dsExpr e
 434                                                        ; return (MkC e') }
 435                                  other       -> pprPanic "HsSplice" (ppr n) }
 436 repE (HsReify _)          = panic "DsMeta.repE: Can't represent reification"
 437 repE e                    =
 438   pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
 439
 440 -----------------------------------------------------------------------------
 441 -- Building representations of auxillary structures like Match, Clause, Stmt,
 442
 443 repMatchTup ::  Match Name -> DsM (Core M.Mtch)
 444 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
 445   do { ss1 <- mkGenSyms (collectPatBinders p)
 446      ; addBinds ss1 $ do {
 447      ; p1 <- repP p
 448      ; (ss2,ds) <- repBinds wheres
 449      ; addBinds ss2 $ do {
 450      ; gs    <- repGuards guards
 451      ; match <- repMatch p1 gs ds
 452      ; wrapGenSyns matTyConName (ss1++ss2) match }}}
 453
 454 repClauseTup ::  Match Name -> DsM (Core M.Clse)
 455 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
 456   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 457      ; addBinds ss1 $ do {
 458        ps1 <- repPs ps
 459      ; (ss2,ds) <- repBinds wheres
 460      ; addBinds ss2 $ do {
 461        gs <- repGuards guards
 462      ; clause <- repClause ps1 gs ds
 463      ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
 464
 465 repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
 466 repGuards [GRHS [ResultStmt e loc] loc2]
 467   = do {a <- repE e; repNormal a }
 468 repGuards other
 469   = do { zs <- mapM process other;
 470          repGuarded (nonEmptyCoreList (map corePair zs)) }
 471   where
 472     process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
 473            = do { x <- repE e1; y <- repE e2; return (x, y) }
 474     process other = panic "Non Haskell 98 guarded body"
 475
 476
 477 -----------------------------------------------------------------------------
 478 -- Representing Stmt's is tricky, especially if bound variables
 479 -- shaddow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 480 -- First gensym new names for every variable in any of the patterns.
 481 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 482 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 483 -- and we could reuse the original names (x and x).
 484 --
 485 -- do { x'1 <- gensym "x"
 486 --    ; x'2 <- gensym "x"
 487 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 488 --          , BindSt (pvar x'2) [| f x |]
 489 --          , NoBindSt [| g x |]
 490 --          ]
 491 --    }
 492
 493 -- The strategy is to translate a whole list of do-bindings by building a
 494 -- bigger environment, and a bigger set of meta bindings
 495 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 496 -- of the expressions within the Do
 497
 498 -----------------------------------------------------------------------------
 499 -- The helper function repSts computes the translation of each sub expression
 500 -- and a bunch of prefix bindings denoting the dynamic renaming.
 501
 502 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
 503 repSts [ResultStmt e loc] =
 504    do { a <- repE e
 505       ; e1 <- repNoBindSt a
 506       ; return ([], [e1]) }
 507 repSts (BindStmt p e loc : ss) =
 508    do { e2 <- repE e
 509       ; ss1 <- mkGenSyms (collectPatBinders p)
 510       ; addBinds ss1 $ do {
 511       ; p1 <- repP p;
 512       ; (ss2,zs) <- repSts ss
 513       ; z <- repBindSt p1 e2
 514       ; return (ss1++ss2, z : zs) }}
 515 repSts (LetStmt bs : ss) =
 516    do { (ss1,ds) <- repBinds bs
 517       ; z <- repLetSt ds
 518       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 519       ; return (ss1++ss2, z : zs) }
 520 repSts (ExprStmt e ty loc : ss) =
 521    do { e2 <- repE e
 522       ; z <- repNoBindSt e2
 523       ; (ss2,zs) <- repSts ss
 524       ; return (ss2, z : zs) }
 525 repSts other = panic "Exotic Stmt in meta brackets"
 526
 527
 528 -----------------------------------------------------------
 529 --                      Bindings
 530 -----------------------------------------------------------
 531
 532 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
 533 repBinds decs
 534  = do { let { bndrs = collectHsBinders decs } ;
 535         ss        <- mkGenSyms bndrs ;
 536         core      <- addBinds ss (rep_binds decs) ;
 537         core_list <- coreList declTyConName core ;
 538         return (ss, core_list) }
 539
 540 rep_binds :: HsBinds Name -> DsM [Core M.Decl]
 541 rep_binds EmptyBinds = return []
 542 rep_binds (ThenBinds x y)
 543  = do { core1 <- rep_binds x
 544       ; core2 <- rep_binds y
 545       ; return (core1 ++ core2) }
 546 rep_binds (MonoBind bs sigs _)
 547  = do { core1 <- rep_monobind bs
 548       ; core2 <- rep_sigs sigs
 549       ; return (core1 ++ core2) }
 550 rep_binds (IPBinds _ _)
 551   = panic "DsMeta:repBinds: can't do implicit parameters"
 552
 553 rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
 554 rep_monobind EmptyMonoBinds     = return []
 555 rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
 556                                        y1 <- rep_monobind y;
 557                                        return (x1 ++ y1) }
 558
 559 -- Note GHC treats declarations of a variable (not a pattern)
 560 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 561 -- with an empty list of patterns
 562 rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
 563  = do { (ss,wherecore) <- repBinds wheres
 564         ; guardcore <- addBinds ss (repGuards guards)
 565         ; fn' <- lookupBinder fn
 566         ; p   <- repPvar fn'
 567         ; ans <- repVal p guardcore wherecore
 568         ; return [ans] }
 569
 570 rep_monobind (FunMonoBind fn infx ms loc)
 571  =   do { ms1 <- mapM repClauseTup ms
 572         ; fn' <- lookupBinder fn
 573         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 574         ; return [ans] }
 575
 576 rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
 577  =   do { patcore <- repP pat
 578         ; (ss,wherecore) <- repBinds wheres
 579         ; guardcore <- addBinds ss (repGuards guards)
 580         ; ans <- repVal patcore guardcore wherecore
 581         ; return [ans] }
 582
 583 rep_monobind (VarMonoBind v e)
 584  =   do { v' <- lookupBinder v
 585         ; e2 <- repE e
 586         ; x <- repNormal e2
 587         ; patcore <- repPvar v'
 588         ; empty_decls <- coreList declTyConName []
 589         ; ans <- repVal patcore x empty_decls
 590         ; return [ans] }
 591
 592 -----------------------------------------------------------------------------
 593 -- Since everything in a MonoBind is mutually recursive we need rename all
 594 -- all the variables simultaneously. For example:
 595 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 596 -- do { f'1 <- gensym "f"
 597 --    ; g'2 <- gensym "g"
 598 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 599 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 600 --      ]}
 601 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 602 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 603 -- together. As we do this we collect GenSymBinds's which represent the renamed
 604 -- variables bound by the Bindings. In order not to lose track of these
 605 -- representations we build a shadow datatype MB with the same structure as
 606 -- MonoBinds, but which has slots for the representations
 607
 608
 609 -----------------------------------------------------------------------------
 610 -- GHC allows a more general form of lambda abstraction than specified
 611 -- by Haskell 98. In particular it allows guarded lambda's like :
 612 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 613 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 614 -- (\ p1 .. pn -> exp) by causing an error.
 615
 616 repLambda :: Match Name -> DsM (Core M.Expr)
 617 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
 618                              EmptyBinds _))
 619  = do { let bndrs = collectPatsBinders ps ;
 620       ; ss <- mkGenSyms bndrs
 621       ; lam <- addBinds ss (
 622                 do { xs <- repPs ps; body <- repE e; repLam xs body })
 623       ; wrapGenSyns expTyConName ss lam }
 624
 625 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 626
 627
 628 -----------------------------------------------------------------------------
 629 --                      Patterns
 630 -- repP deals with patterns.  It assumes that we have already
 631 -- walked over the pattern(s) once to collect the binders, and
 632 -- have extended the environment.  So every pattern-bound
 633 -- variable should already appear in the environment.
 634
 635 -- Process a list of patterns
 636 repPs :: [Pat Name] -> DsM (Core [M.Patt])
 637 repPs ps = do { ps' <- mapM repP ps ;
 638                 coreList pattTyConName ps' }
 639
 640 repP :: Pat Name -> DsM (Core M.Patt)
 641 repP (WildPat _)     = repPwild
 642 repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
 643 repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
 644 repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
 645 repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
 646 repP (ParPat p)      = repP p
 647 repP (ListPat ps _)  = repListPat ps
 648 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
 649 repP (ConPatIn dc details)
 650  = do { con_str <- lookupOcc dc
 651       ; case details of
 652          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
 653          RecCon pairs   -> error "No records in template haskell yet"
 654          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
 655    }
 656 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
 657 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
 658 repP other = panic "Exotic pattern inside meta brackets"
 659
 660 repListPat :: [Pat Name] -> DsM (Core M.Patt)
 661 repListPat []     = do { nil_con <- coreStringLit "[]"
 662                        ; nil_args <- coreList pattTyConName []
 663                        ; repPcon nil_con nil_args }
 664 repListPat (p:ps) = do { p2 <- repP p
 665                        ; ps2 <- repListPat ps
 666                        ; cons_con <- coreStringLit ":"
 667                        ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
 668
 669
 670 ----------------------------------------------------------
 671 --      The meta-environment
 672
 673 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 674                                 -- I.e.         (x, x_id) means
 675                                 --      let x_id = gensym "x" in ...
 676
 677 addBinds :: [GenSymBind] -> DsM a -> DsM a
 678 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 679
 680 mkGenSym :: Name -> DsM GenSymBind
 681 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
 682
 683 mkGenSyms :: [Name] -> DsM [GenSymBind]
 684 mkGenSyms ns = mapM mkGenSym ns
 685
 686 lookupBinder :: Name -> DsM (Core String)
 687 lookupBinder n
 688   = do { mb_val <- dsLookupMetaEnv n;
 689          case mb_val of
 690             Just (Bound x) -> return (coreVar x)
 691             other          -> pprPanic "Failed binder lookup:" (ppr n) }
 692
 693 lookupOcc :: Name -> DsM (Core String)
 694 -- Lookup an occurrence; it can't be a splice.
 695 -- Use the in-scope bindings if they exist
 696 lookupOcc n
 697   = do {  mb_val <- dsLookupMetaEnv n ;
 698           case mb_val of
 699                 Nothing         -> globalVar n
 700                 Just (Bound x)  -> return (coreVar x)
 701                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
 702     }
 703
 704 globalVar :: Name -> DsM (Core String)
 705 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
 706             where
 707               name_mod = moduleUserString (nameModule n)
 708               name_occ = occNameUserString (nameOccName n)
 709
 710 localVar :: Name -> DsM (Core String)
 711 localVar n = coreStringLit (occNameUserString (nameOccName n))
 712
 713 lookupType :: Name      -- Name of type constructor (e.g. M.Expr)
 714            -> DsM Type  -- The type
 715 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 716                           return (mkGenTyConApp tc []) }
 717
 718 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
 719 --      --> bindQ (gensym nm1) (\ id1 ->
 720 --          bindQ (gensym nm2 (\ id2 ->
 721 --          y))
 722
 723 wrapGenSyns :: Name     -- Name of the type (consructor) for 'a'
 724             -> [GenSymBind]
 725             -> Core (M.Q a) -> DsM (Core (M.Q a))
 726 wrapGenSyns tc_name binds body@(MkC b)
 727   = do { elt_ty <- lookupType tc_name
 728        ; go elt_ty binds }
 729   where
 730     go elt_ty [] = return body
 731     go elt_ty ((name,id) : binds)
 732       = do { MkC body'  <- go elt_ty binds
 733            ; lit_str    <- localVar name
 734            ; gensym_app <- repGensym lit_str
 735            ; repBindQ stringTy elt_ty
 736                       gensym_app (MkC (Lam id body')) }
 737
 738 -- Just like wrapGenSym, but don't actually do the gensym
 739 -- Instead use the existing name
 740 -- Only used for [Decl]
 741 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
 742 wrapNongenSyms binds (MkC body)
 743   = do { binds' <- mapM do_one binds ;
 744          return (MkC (mkLets binds' body)) }
 745   where
 746     do_one (name,id)
 747         = do { MkC lit_str <- localVar name     -- No gensym
 748              ; return (NonRec id lit_str) }
 749
 750 void = placeHolderType
 751
 752 string :: String -> HsExpr Id
 753 string s = HsLit (HsString (mkFastString s))
 754
 755
 756 -- %*********************************************************************
 757 -- %*                                                                   *
 758 --              Constructing code
 759 -- %*                                                                   *
 760 -- %*********************************************************************
 761
 762 -----------------------------------------------------------------------------
 763 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 764 -- we invent a new datatype which uses phantom types.
 765
 766 newtype Core a = MkC CoreExpr
 767 unC (MkC x) = x
 768
 769 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 770 rep2 n xs = do { id <- dsLookupGlobalId n
 771                ; return (MkC (foldl App (Var id) xs)) }
 772
 773 -- Then we make "repConstructors" which use the phantom types for each of the
 774 -- smart constructors of the Meta.Meta datatypes.
 775
 776
 777 -- %*********************************************************************
 778 -- %*                                                                   *
 779 --              The 'smart constructors'
 780 -- %*                                                                   *
 781 -- %*********************************************************************
 782
 783 --------------- Patterns -----------------
 784 repPlit   :: Core M.Lit -> DsM (Core M.Patt)
 785 repPlit (MkC l) = rep2 plitName [l]
 786
 787 repPvar :: Core String -> DsM (Core M.Patt)
 788 repPvar (MkC s) = rep2 pvarName [s]
 789
 790 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
 791 repPtup (MkC ps) = rep2 ptupName [ps]
 792
 793 repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
 794 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
 795
 796 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
 797 repPtilde (MkC p) = rep2 ptildeName [p]
 798
 799 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
 800 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
 801
 802 repPwild  :: DsM (Core M.Patt)
 803 repPwild = rep2 pwildName []
 804
 805 --------------- Expressions -----------------
 806 repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
 807 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
 808                    | otherwise                  = repVar str
 809
 810 repVar :: Core String -> DsM (Core M.Expr)
 811 repVar (MkC s) = rep2 varName [s]
 812
 813 repCon :: Core String -> DsM (Core M.Expr)
 814 repCon (MkC s) = rep2 conName [s]
 815
 816 repLit :: Core M.Lit -> DsM (Core M.Expr)
 817 repLit (MkC c) = rep2 litName [c]
 818
 819 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 820 repApp (MkC x) (MkC y) = rep2 appName [x,y]
 821
 822 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
 823 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
 824
 825 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
 826 repTup (MkC es) = rep2 tupName [es]
 827
 828 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 829 repCond (MkC x) (MkC y) (MkC z) =  rep2 condName [x,y,z]
 830
 831 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
 832 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 833
 834 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
 835 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 836
 837 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
 838 repDoE (MkC ss) = rep2 doEName [ss]
 839
 840 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
 841 repComp (MkC ss) = rep2 compName [ss]
 842
 843 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
 844 repListExp (MkC es) = rep2 listExpName [es]
 845
 846 repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
 847 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
 848
 849 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
 850 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 851
 852 repNeg :: Core M.Expr -> DsM (Core M.Expr)
 853 repNeg (MkC x) = rep2 negName [x]
 854
 855 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 856 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
 857
 858 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 859 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
 860
 861 ------------ Right hand sides (guarded expressions) ----
 862 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
 863 repGuarded (MkC pairs) = rep2 guardedName [pairs]
 864
 865 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
 866 repNormal (MkC e) = rep2 normalName [e]
 867
 868 ------------- Statements -------------------
 869 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
 870 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
 871
 872 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
 873 repLetSt (MkC ds) = rep2 letStName [ds]
 874
 875 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
 876 repNoBindSt (MkC e) = rep2 noBindStName [e]
 877
 878 -------------- DotDot (Arithmetic sequences) -----------
 879 repFrom :: Core M.Expr -> DsM (Core M.Expr)
 880 repFrom (MkC x) = rep2 fromName [x]
 881
 882 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 883 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
 884
 885 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 886 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
 887
 888 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 889 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
 890
 891 ------------ Match and Clause Tuples -----------
 892 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
 893 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
 894
 895 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
 896 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
 897
 898 -------------- Dec -----------------------------
 899 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
 900 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
 901
 902 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
 903 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 904
 905 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
 906 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
 907
 908 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
 909 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
 910
 911 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
 912 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
 913
 914 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
 915 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
 916
 917 repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
 918 repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
 919
 920 ------------ Types -------------------
 921
 922 repTvar :: Core String -> DsM (Core M.Type)
 923 repTvar (MkC s) = rep2 tvarName [s]
 924
 925 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
 926 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
 927
 928 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
 929 repTapps f []     = return f
 930 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 931
 932 --------- Type constructors --------------
 933
 934 repNamedTyCon :: Core String -> DsM (Core M.Type)
 935 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
 936
 937 repTupleTyCon :: Int -> DsM (Core M.Type)
 938 -- Note: not Core Int; it's easier to be direct here
 939 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
 940
 941 repArrowTyCon :: DsM (Core M.Type)
 942 repArrowTyCon = rep2 arrowTyConName []
 943
 944 repListTyCon :: DsM (Core M.Type)
 945 repListTyCon = rep2 listTyConName []
 946
 947
 948 ----------------------------------------------------------
 949 --              Literals
 950
 951 repLiteral :: HsLit -> DsM (Core M.Lit)
 952 repLiteral lit
 953   = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
 954   where
 955     lit_name = case lit of
 956                  HsInt _    -> intLName
 957                  HsChar _   -> charLName
 958                  HsString _ -> stringLName
 959                  HsRat _ _  -> rationalLName
 960                  other      -> uh_oh
 961     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
 962                     (ppr lit)
 963
 964 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
 965 repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInt i)
 966 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
 967                                                repLiteral (HsRat f rat_ty) }
 968         -- The type Rational will be in the environment, becuase
 969         -- the smart constructor 'THSyntax.rationalL' uses it in its type,
 970         -- and rationalL is sucked in when any TH stuff is used
 971
 972 --------------- Miscellaneous -------------------
 973
 974 repLift :: Core e -> DsM (Core M.Expr)
 975 repLift (MkC x) = rep2 liftName [x]
 976
 977 repGensym :: Core String -> DsM (Core (M.Q String))
 978 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
 979
 980 repBindQ :: Type -> Type        -- a and b
 981          -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
 982 repBindQ ty_a ty_b (MkC x) (MkC y)
 983   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
 984
 985 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
 986 repSequenceQ ty_a (MkC list)
 987   = rep2 sequenceQName [Type ty_a, list]
 988
 989 ------------ Lists and Tuples -------------------
 990 -- turn a list of patterns into a single pattern matching a list
 991
 992 coreList :: Name        -- Of the TyCon of the element type
 993          -> [Core a] -> DsM (Core [a])
 994 coreList tc_name es
 995   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
 996
 997 coreList' :: Type       -- The element type
 998           -> [Core a] -> Core [a]
 999 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1000
1001 nonEmptyCoreList :: [Core a] -> Core [a]
1002   -- The list must be non-empty so we can get the element type
1003   -- Otherwise use coreList
1004 nonEmptyCoreList []           = panic "coreList: empty argument"
1005 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1006
1007 corePair :: (Core a, Core b) -> Core (a,b)
1008 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1009
1010 coreStringLit :: String -> DsM (Core String)
1011 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1012
1013 coreVar :: Id -> Core String    -- The Id has type String
1014 coreVar id = MkC (Var id)
1015
1016
1017
1018 -- %************************************************************************
1019 -- %*                                                                   *
1020 --              The known-key names for Template Haskell
1021 -- %*                                                                   *
1022 -- %************************************************************************
1023
1024 -- To add a name, do three things
1025 --
1026 --  1) Allocate a key
1027 --  2) Make a "Name"
1028 --  3) Add the name to knownKeyNames
1029
1030 templateHaskellNames :: NameSet
1031 -- The names that are implicitly mentioned by ``bracket''
1032 -- Should stay in sync with the import list of DsMeta
1033 templateHaskellNames
1034   = mkNameSet [ intLName,charLName, stringLName, rationalLName,
1035                 plitName, pvarName, ptupName,
1036                 pconName, ptildeName, paspatName, pwildName,
1037                 varName, conName, litName, appName, infixEName, lamName,
1038                 tupName, doEName, compName,
1039                 listExpName, sigExpName, condName, letEName, caseEName,
1040                 infixAppName, negName, sectionLName, sectionRName,
1041                 guardedName, normalName,
1042                 bindStName, letStName, noBindStName, parStName,
1043                 fromName, fromThenName, fromToName, fromThenToName,
1044                 funName, valName, liftName,
1045                 gensymName, returnQName, bindQName, sequenceQName,
1046                 matchName, clauseName, funName, valName, dataDName, classDName,
1047                 instName, protoName, tvarName, tconName, tappName,
1048                 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
1049                 constrName,
1050                 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
1051                 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1052                 qTyConName, expTyConName, matTyConName, clsTyConName,
1053                 decTyConName, typTyConName ]
1054
1055
1056 varQual  = mk_known_key_name OccName.varName
1057 tcQual   = mk_known_key_name OccName.tcName
1058
1059 thModule :: Module
1060 -- NB: the THSyntax module comes from the "haskell-src" package
1061 thModule = mkThPkgModule mETA_META_Name
1062
1063 mk_known_key_name space str uniq
1064   = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1065
1066 intLName       = varQual FSLIT("intL")          intLIdKey
1067 charLName      = varQual FSLIT("charL")         charLIdKey
1068 stringLName    = varQual FSLIT("stringL")       stringLIdKey
1069 rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
1070 plitName       = varQual FSLIT("plit")          plitIdKey
1071 pvarName       = varQual FSLIT("pvar")          pvarIdKey
1072 ptupName       = varQual FSLIT("ptup")          ptupIdKey
1073 pconName       = varQual FSLIT("pcon")          pconIdKey
1074 ptildeName     = varQual FSLIT("ptilde")        ptildeIdKey
1075 paspatName     = varQual FSLIT("paspat")        paspatIdKey
1076 pwildName      = varQual FSLIT("pwild")         pwildIdKey
1077 varName        = varQual FSLIT("var")           varIdKey
1078 conName        = varQual FSLIT("con")           conIdKey
1079 litName        = varQual FSLIT("lit")           litIdKey
1080 appName        = varQual FSLIT("app")           appIdKey
1081 infixEName     = varQual FSLIT("infixE")        infixEIdKey
1082 lamName        = varQual FSLIT("lam")           lamIdKey
1083 tupName        = varQual FSLIT("tup")           tupIdKey
1084 doEName        = varQual FSLIT("doE")           doEIdKey
1085 compName       = varQual FSLIT("comp")          compIdKey
1086 listExpName    = varQual FSLIT("listExp")       listExpIdKey
1087 sigExpName     = varQual FSLIT("sigExp")        sigExpIdKey
1088 condName       = varQual FSLIT("cond")          condIdKey
1089 letEName       = varQual FSLIT("letE")          letEIdKey
1090 caseEName      = varQual FSLIT("caseE")         caseEIdKey
1091 infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
1092 negName        = varQual FSLIT("neg")           negIdKey
1093 sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
1094 sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
1095 guardedName    = varQual FSLIT("guarded")       guardedIdKey
1096 normalName     = varQual FSLIT("normal")        normalIdKey
1097 bindStName     = varQual FSLIT("bindSt")        bindStIdKey
1098 letStName      = varQual FSLIT("letSt")         letStIdKey
1099 noBindStName   = varQual FSLIT("noBindSt")      noBindStIdKey
1100 parStName      = varQual FSLIT("parSt")         parStIdKey
1101 fromName       = varQual FSLIT("from")          fromIdKey
1102 fromThenName   = varQual FSLIT("fromThen")      fromThenIdKey
1103 fromToName     = varQual FSLIT("fromTo")        fromToIdKey
1104 fromThenToName = varQual FSLIT("fromThenTo")    fromThenToIdKey
1105 liftName       = varQual FSLIT("lift")          liftIdKey
1106 gensymName     = varQual FSLIT("gensym")        gensymIdKey
1107 returnQName    = varQual FSLIT("returnQ")       returnQIdKey
1108 bindQName      = varQual FSLIT("bindQ")         bindQIdKey
1109 sequenceQName  = varQual FSLIT("sequenceQ")     sequenceQIdKey
1110
1111 -- type Mat = ...
1112 matchName      = varQual FSLIT("match")         matchIdKey
1113
1114 -- type Cls = ...
1115 clauseName     = varQual FSLIT("clause")        clauseIdKey
1116
1117 -- data Dec = ...
1118 funName        = varQual FSLIT("fun")           funIdKey
1119 valName        = varQual FSLIT("val")           valIdKey
1120 dataDName      = varQual FSLIT("dataD")         dataDIdKey
1121 classDName     = varQual FSLIT("classD")        classDIdKey
1122 instName       = varQual FSLIT("inst")          instIdKey
1123 protoName      = varQual FSLIT("proto")         protoIdKey
1124
1125 -- data Typ = ...
1126 tvarName       = varQual FSLIT("tvar")          tvarIdKey
1127 tconName       = varQual FSLIT("tcon")          tconIdKey
1128 tappName       = varQual FSLIT("tapp")          tappIdKey
1129
1130 -- data Tag = ...
1131 arrowTyConName = varQual FSLIT("arrowTyCon")   arrowIdKey
1132 tupleTyConName = varQual FSLIT("tupleTyCon")   tupleIdKey
1133 listTyConName  = varQual FSLIT("listTyCon")    listIdKey
1134 namedTyConName = varQual FSLIT("namedTyCon")   namedTyConIdKey
1135
1136 -- data Con = ...
1137 constrName     = varQual FSLIT("constr")        constrIdKey
1138
1139 exprTyConName  = tcQual  FSLIT("Expr")                 exprTyConKey
1140 declTyConName  = tcQual  FSLIT("Decl")                 declTyConKey
1141 pattTyConName  = tcQual  FSLIT("Patt")                 pattTyConKey
1142 mtchTyConName  = tcQual  FSLIT("Mtch")                 mtchTyConKey
1143 clseTyConName  = tcQual  FSLIT("Clse")                 clseTyConKey
1144 stmtTyConName  = tcQual  FSLIT("Stmt")         stmtTyConKey
1145 consTyConName  = tcQual  FSLIT("Cons")                 consTyConKey
1146 typeTyConName  = tcQual  FSLIT("Type")                 typeTyConKey
1147
1148 qTyConName     = tcQual  FSLIT("Q")            qTyConKey
1149 expTyConName   = tcQual  FSLIT("Exp")          expTyConKey
1150 decTyConName   = tcQual  FSLIT("Dec")          decTyConKey
1151 typTyConName   = tcQual  FSLIT("Typ")          typTyConKey
1152 matTyConName   = tcQual  FSLIT("Mat")          matTyConKey
1153 clsTyConName   = tcQual  FSLIT("Cls")          clsTyConKey
1154
1155 --      TyConUniques available: 100-119
1156 --      Check in PrelNames if you want to change this
1157
1158 expTyConKey  = mkPreludeTyConUnique 100
1159 matTyConKey  = mkPreludeTyConUnique 101
1160 clsTyConKey  = mkPreludeTyConUnique 102
1161 qTyConKey    = mkPreludeTyConUnique 103
1162 exprTyConKey = mkPreludeTyConUnique 104
1163 declTyConKey = mkPreludeTyConUnique 105
1164 pattTyConKey = mkPreludeTyConUnique 106
1165 mtchTyConKey = mkPreludeTyConUnique 107
1166 clseTyConKey = mkPreludeTyConUnique 108
1167 stmtTyConKey = mkPreludeTyConUnique 109
1168 consTyConKey = mkPreludeTyConUnique 110
1169 typeTyConKey = mkPreludeTyConUnique 111
1170 typTyConKey  = mkPreludeTyConUnique 112
1171 decTyConKey  = mkPreludeTyConUnique 113
1172
1173
1174
1175 --      IdUniques available: 200-299
1176 --      If you want to change this, make sure you check in PrelNames
1177 fromIdKey       = mkPreludeMiscIdUnique 200
1178 fromThenIdKey   = mkPreludeMiscIdUnique 201
1179 fromToIdKey     = mkPreludeMiscIdUnique 202
1180 fromThenToIdKey = mkPreludeMiscIdUnique 203
1181 liftIdKey       = mkPreludeMiscIdUnique 204
1182 gensymIdKey     = mkPreludeMiscIdUnique 205
1183 returnQIdKey    = mkPreludeMiscIdUnique 206
1184 bindQIdKey      = mkPreludeMiscIdUnique 207
1185 funIdKey        = mkPreludeMiscIdUnique 208
1186 valIdKey        = mkPreludeMiscIdUnique 209
1187 protoIdKey      = mkPreludeMiscIdUnique 210
1188 matchIdKey      = mkPreludeMiscIdUnique 211
1189 clauseIdKey     = mkPreludeMiscIdUnique 212
1190 intLIdKey       = mkPreludeMiscIdUnique 213
1191 charLIdKey      = mkPreludeMiscIdUnique 214
1192
1193 classDIdKey     = mkPreludeMiscIdUnique 215
1194 instIdKey       = mkPreludeMiscIdUnique 216
1195 dataDIdKey      = mkPreludeMiscIdUnique 217
1196
1197 sequenceQIdKey  = mkPreludeMiscIdUnique 218
1198
1199 plitIdKey       = mkPreludeMiscIdUnique 220
1200 pvarIdKey       = mkPreludeMiscIdUnique 221
1201 ptupIdKey       = mkPreludeMiscIdUnique 222
1202 pconIdKey       = mkPreludeMiscIdUnique 223
1203 ptildeIdKey     = mkPreludeMiscIdUnique 224
1204 paspatIdKey     = mkPreludeMiscIdUnique 225
1205 pwildIdKey      = mkPreludeMiscIdUnique 226
1206 varIdKey        = mkPreludeMiscIdUnique 227
1207 conIdKey        = mkPreludeMiscIdUnique 228
1208 litIdKey        = mkPreludeMiscIdUnique 229
1209 appIdKey        = mkPreludeMiscIdUnique 230
1210 infixEIdKey     = mkPreludeMiscIdUnique 231
1211 lamIdKey        = mkPreludeMiscIdUnique 232
1212 tupIdKey        = mkPreludeMiscIdUnique 233
1213 doEIdKey        = mkPreludeMiscIdUnique 234
1214 compIdKey       = mkPreludeMiscIdUnique 235
1215 listExpIdKey    = mkPreludeMiscIdUnique 237
1216 condIdKey       = mkPreludeMiscIdUnique 238
1217 letEIdKey       = mkPreludeMiscIdUnique 239
1218 caseEIdKey      = mkPreludeMiscIdUnique 240
1219 infixAppIdKey   = mkPreludeMiscIdUnique 241
1220 negIdKey        = mkPreludeMiscIdUnique 242
1221 sectionLIdKey   = mkPreludeMiscIdUnique 243
1222 sectionRIdKey   = mkPreludeMiscIdUnique 244
1223 guardedIdKey    = mkPreludeMiscIdUnique 245
1224 normalIdKey     = mkPreludeMiscIdUnique 246
1225 bindStIdKey     = mkPreludeMiscIdUnique 247
1226 letStIdKey      = mkPreludeMiscIdUnique 248
1227 noBindStIdKey   = mkPreludeMiscIdUnique 249
1228 parStIdKey      = mkPreludeMiscIdUnique 250
1229
1230 tvarIdKey       = mkPreludeMiscIdUnique 251
1231 tconIdKey       = mkPreludeMiscIdUnique 252
1232 tappIdKey       = mkPreludeMiscIdUnique 253
1233
1234 arrowIdKey      = mkPreludeMiscIdUnique 254
1235 tupleIdKey      = mkPreludeMiscIdUnique 255
1236 listIdKey       = mkPreludeMiscIdUnique 256
1237 namedTyConIdKey = mkPreludeMiscIdUnique 257
1238
1239 constrIdKey     = mkPreludeMiscIdUnique 258
1240
1241 stringLIdKey    = mkPreludeMiscIdUnique 259
1242 rationalLIdKey  = mkPreludeMiscIdUnique 260
1243
1244 sigExpIdKey     = mkPreludeMiscIdUnique 261
1245
1246
1247
1248 -- %************************************************************************
1249 -- %*                                                                   *
1250 --              Other utilities
1251 -- %*                                                                   *
1252 -- %************************************************************************
1253
1254 -- It is rather usatisfactory that we don't have a SrcLoc
1255 addDsWarn :: SDoc -> DsM ()
1256 addDsWarn msg = dsWarn (noSrcLoc, msg)