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