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