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