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