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                  HsInt     _ -> integerLName
1093                  HsChar _    -> charLName
1094                  HsString _  -> stringLName
1095                  HsRat _ _   -> rationalLName
1096                  other       -> uh_oh
1097     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1098                     (ppr lit)
1099
1100 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1101 repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInteger i)
1102 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
1103                                                repLiteral (HsRat f rat_ty) }
1104         -- The type Rational will be in the environment, becuase
1105         -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1106         -- and rationalL is sucked in when any TH stuff is used
1107
1108 --------------- Miscellaneous -------------------
1109
1110 repLift :: Core e -> DsM (Core M.Expr)
1111 repLift (MkC x) = rep2 liftName [x]
1112
1113 repGensym :: Core String -> DsM (Core (M.Q String))
1114 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1115
1116 repBindQ :: Type -> Type        -- a and b
1117          -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1118 repBindQ ty_a ty_b (MkC x) (MkC y)
1119   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1120
1121 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1122 repSequenceQ ty_a (MkC list)
1123   = rep2 sequenceQName [Type ty_a, list]
1124
1125 ------------ Lists and Tuples -------------------
1126 -- turn a list of patterns into a single pattern matching a list
1127
1128 coreList :: Name        -- Of the TyCon of the element type
1129          -> [Core a] -> DsM (Core [a])
1130 coreList tc_name es
1131   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1132
1133 coreList' :: Type       -- The element type
1134           -> [Core a] -> Core [a]
1135 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1136
1137 nonEmptyCoreList :: [Core a] -> Core [a]
1138   -- The list must be non-empty so we can get the element type
1139   -- Otherwise use coreList
1140 nonEmptyCoreList []           = panic "coreList: empty argument"
1141 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1142
1143 corePair :: (Core a, Core b) -> Core (a,b)
1144 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1145
1146 coreStringLit :: String -> DsM (Core String)
1147 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1148
1149 coreVar :: Id -> Core String    -- The Id has type String
1150 coreVar id = MkC (Var id)
1151
1152
1153
1154 -- %************************************************************************
1155 -- %*                                                                   *
1156 --              The known-key names for Template Haskell
1157 -- %*                                                                   *
1158 -- %************************************************************************
1159
1160 -- To add a name, do three things
1161 --
1162 --  1) Allocate a key
1163 --  2) Make a "Name"
1164 --  3) Add the name to knownKeyNames
1165
1166 templateHaskellNames :: NameSet
1167 -- The names that are implicitly mentioned by ``bracket''
1168 -- Should stay in sync with the import list of DsMeta
1169 templateHaskellNames
1170   = mkNameSet [ integerLName, charLName, stringLName, rationalLName,
1171                 plitName, pvarName, ptupName,
1172                 pconName, ptildeName, paspatName, pwildName,
1173                 varName, conName, litName, appName, infixEName, lamName,
1174                 tupName, doEName, compName,
1175                 listExpName, sigExpName, condName, letEName, caseEName,
1176                 infixAppName, sectionLName, sectionRName,
1177                 guardedName, normalName,
1178                 bindStName, letStName, noBindStName, parStName,
1179                 fromName, fromThenName, fromToName, fromThenToName,
1180                 funName, valName, liftName,
1181                 gensymName, returnQName, bindQName, sequenceQName,
1182                 matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
1183                 instName, protoName, tforallName, tvarName, tconName, tappName,
1184                 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
1185                 ctxtName, constrName, recConstrName, infixConstrName,
1186                 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
1187                 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1188         strTypeTyConName, varStrTypeTyConName,
1189                 qTyConName, expTyConName, matTyConName, clsTyConName,
1190                 decTyConName, typTyConName, strictTypeName, varStrictTypeName,
1191         recConName, recUpdName, precName,
1192         fieldName, fieldTyConName, fieldPName, fieldPTyConName,
1193         strictName, nonstrictName ]
1194
1195
1196 varQual  = mk_known_key_name OccName.varName
1197 tcQual   = mk_known_key_name OccName.tcName
1198
1199 thModule :: Module
1200 -- NB: the THSyntax module comes from the "haskell-src" package
1201 thModule = mkThPkgModule mETA_META_Name
1202
1203 mk_known_key_name space str uniq
1204   = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1205
1206 integerLName   = varQual FSLIT("integerL")      integerLIdKey
1207 charLName      = varQual FSLIT("charL")         charLIdKey
1208 stringLName    = varQual FSLIT("stringL")       stringLIdKey
1209 rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
1210 plitName       = varQual FSLIT("plit")          plitIdKey
1211 pvarName       = varQual FSLIT("pvar")          pvarIdKey
1212 ptupName       = varQual FSLIT("ptup")          ptupIdKey
1213 pconName       = varQual FSLIT("pcon")          pconIdKey
1214 ptildeName     = varQual FSLIT("ptilde")        ptildeIdKey
1215 paspatName     = varQual FSLIT("paspat")        paspatIdKey
1216 pwildName      = varQual FSLIT("pwild")         pwildIdKey
1217 precName       = varQual FSLIT("prec")          precIdKey
1218 varName        = varQual FSLIT("var")           varIdKey
1219 conName        = varQual FSLIT("con")           conIdKey
1220 litName        = varQual FSLIT("lit")           litIdKey
1221 appName        = varQual FSLIT("app")           appIdKey
1222 infixEName     = varQual FSLIT("infixE")        infixEIdKey
1223 lamName        = varQual FSLIT("lam")           lamIdKey
1224 tupName        = varQual FSLIT("tup")           tupIdKey
1225 doEName        = varQual FSLIT("doE")           doEIdKey
1226 compName       = varQual FSLIT("comp")          compIdKey
1227 listExpName    = varQual FSLIT("listExp")       listExpIdKey
1228 sigExpName     = varQual FSLIT("sigExp")        sigExpIdKey
1229 condName       = varQual FSLIT("cond")          condIdKey
1230 letEName       = varQual FSLIT("letE")          letEIdKey
1231 caseEName      = varQual FSLIT("caseE")         caseEIdKey
1232 infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
1233 sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
1234 sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
1235 recConName     = varQual FSLIT("recCon")        recConIdKey
1236 recUpdName     = varQual FSLIT("recUpd")        recUpdIdKey
1237 guardedName    = varQual FSLIT("guarded")       guardedIdKey
1238 normalName     = varQual FSLIT("normal")        normalIdKey
1239 bindStName     = varQual FSLIT("bindSt")        bindStIdKey
1240 letStName      = varQual FSLIT("letSt")         letStIdKey
1241 noBindStName   = varQual FSLIT("noBindSt")      noBindStIdKey
1242 parStName      = varQual FSLIT("parSt")         parStIdKey
1243 fromName       = varQual FSLIT("from")          fromIdKey
1244 fromThenName   = varQual FSLIT("fromThen")      fromThenIdKey
1245 fromToName     = varQual FSLIT("fromTo")        fromToIdKey
1246 fromThenToName = varQual FSLIT("fromThenTo")    fromThenToIdKey
1247 liftName       = varQual FSLIT("lift")          liftIdKey
1248 gensymName     = varQual FSLIT("gensym")        gensymIdKey
1249 returnQName    = varQual FSLIT("returnQ")       returnQIdKey
1250 bindQName      = varQual FSLIT("bindQ")         bindQIdKey
1251 sequenceQName  = varQual FSLIT("sequenceQ")     sequenceQIdKey
1252
1253 -- type Mat = ...
1254 matchName      = varQual FSLIT("match")         matchIdKey
1255
1256 -- type Cls = ...
1257 clauseName     = varQual FSLIT("clause")        clauseIdKey
1258
1259 -- data Dec = ...
1260 funName        = varQual FSLIT("fun")           funIdKey
1261 valName        = varQual FSLIT("val")           valIdKey
1262 dataDName      = varQual FSLIT("dataD")         dataDIdKey
1263 tySynDName     = varQual FSLIT("tySynD")        tySynDIdKey
1264 classDName     = varQual FSLIT("classD")        classDIdKey
1265 instName       = varQual FSLIT("inst")          instIdKey
1266 protoName      = varQual FSLIT("proto")         protoIdKey
1267
1268 -- data Typ = ...
1269 tforallName    = varQual FSLIT("tforall")       tforallIdKey
1270 tvarName       = varQual FSLIT("tvar")          tvarIdKey
1271 tconName       = varQual FSLIT("tcon")          tconIdKey
1272 tappName       = varQual FSLIT("tapp")          tappIdKey
1273
1274 -- data Tag = ...
1275 arrowTyConName = varQual FSLIT("arrowTyCon")    arrowIdKey
1276 tupleTyConName = varQual FSLIT("tupleTyCon")    tupleIdKey
1277 listTyConName  = varQual FSLIT("listTyCon")     listIdKey
1278 namedTyConName = varQual FSLIT("namedTyCon")    namedTyConIdKey
1279
1280 -- type Ctxt = ...
1281 ctxtName       = varQual FSLIT("ctxt")          ctxtIdKey
1282
1283 -- data Con = ...
1284 constrName     = varQual FSLIT("constr")        constrIdKey
1285 recConstrName  = varQual FSLIT("recConstr")     recConstrIdKey
1286 infixConstrName = varQual FSLIT("infixConstr")  infixConstrIdKey
1287
1288 exprTyConName  = tcQual  FSLIT("Expr")                 exprTyConKey
1289 declTyConName  = tcQual  FSLIT("Decl")                 declTyConKey
1290 pattTyConName  = tcQual  FSLIT("Patt")                 pattTyConKey
1291 mtchTyConName  = tcQual  FSLIT("Mtch")                 mtchTyConKey
1292 clseTyConName  = tcQual  FSLIT("Clse")                 clseTyConKey
1293 stmtTyConName  = tcQual  FSLIT("Stmt")         stmtTyConKey
1294 consTyConName  = tcQual  FSLIT("Cons")                 consTyConKey
1295 typeTyConName  = tcQual  FSLIT("Type")                 typeTyConKey
1296 strTypeTyConName  = tcQual  FSLIT("StrType")       strTypeTyConKey
1297 varStrTypeTyConName  = tcQual  FSLIT("VarStrType")       varStrTypeTyConKey
1298
1299 fieldTyConName = tcQual FSLIT("FldE")              fieldTyConKey
1300 fieldPTyConName = tcQual FSLIT("FldP")             fieldPTyConKey
1301
1302 qTyConName     = tcQual  FSLIT("Q")            qTyConKey
1303 expTyConName   = tcQual  FSLIT("Exp")          expTyConKey
1304 decTyConName   = tcQual  FSLIT("Dec")          decTyConKey
1305 typTyConName   = tcQual  FSLIT("Typ")          typTyConKey
1306 matTyConName   = tcQual  FSLIT("Mat")          matTyConKey
1307 clsTyConName   = tcQual  FSLIT("Cls")          clsTyConKey
1308
1309 strictTypeName = varQual  FSLIT("strictType")   strictTypeKey
1310 varStrictTypeName = varQual  FSLIT("varStrictType")   varStrictTypeKey
1311 strictName     = varQual  FSLIT("strict")       strictKey
1312 nonstrictName  = varQual  FSLIT("nonstrict")    nonstrictKey
1313
1314 fieldName = varQual FSLIT("field")              fieldKey
1315 fieldPName = varQual FSLIT("fieldP")            fieldPKey
1316
1317 --      TyConUniques available: 100-119
1318 --      Check in PrelNames if you want to change this
1319
1320 expTyConKey  = mkPreludeTyConUnique 100
1321 matTyConKey  = mkPreludeTyConUnique 101
1322 clsTyConKey  = mkPreludeTyConUnique 102
1323 qTyConKey    = mkPreludeTyConUnique 103
1324 exprTyConKey = mkPreludeTyConUnique 104
1325 declTyConKey = mkPreludeTyConUnique 105
1326 pattTyConKey = mkPreludeTyConUnique 106
1327 mtchTyConKey = mkPreludeTyConUnique 107
1328 clseTyConKey = mkPreludeTyConUnique 108
1329 stmtTyConKey = mkPreludeTyConUnique 109
1330 consTyConKey = mkPreludeTyConUnique 110
1331 typeTyConKey = mkPreludeTyConUnique 111
1332 typTyConKey  = mkPreludeTyConUnique 112
1333 decTyConKey  = mkPreludeTyConUnique 113
1334 varStrTypeTyConKey = mkPreludeTyConUnique 114
1335 strTypeTyConKey = mkPreludeTyConUnique 115
1336 fieldTyConKey = mkPreludeTyConUnique 116
1337 fieldPTyConKey = mkPreludeTyConUnique 117
1338
1339
1340
1341 --      IdUniques available: 200-299
1342 --      If you want to change this, make sure you check in PrelNames
1343 fromIdKey       = mkPreludeMiscIdUnique 200
1344 fromThenIdKey   = mkPreludeMiscIdUnique 201
1345 fromToIdKey     = mkPreludeMiscIdUnique 202
1346 fromThenToIdKey = mkPreludeMiscIdUnique 203
1347 liftIdKey       = mkPreludeMiscIdUnique 204
1348 gensymIdKey     = mkPreludeMiscIdUnique 205
1349 returnQIdKey    = mkPreludeMiscIdUnique 206
1350 bindQIdKey      = mkPreludeMiscIdUnique 207
1351 funIdKey        = mkPreludeMiscIdUnique 208
1352 valIdKey        = mkPreludeMiscIdUnique 209
1353 protoIdKey      = mkPreludeMiscIdUnique 210
1354 matchIdKey      = mkPreludeMiscIdUnique 211
1355 clauseIdKey     = mkPreludeMiscIdUnique 212
1356 integerLIdKey   = mkPreludeMiscIdUnique 213
1357 charLIdKey      = mkPreludeMiscIdUnique 214
1358
1359 classDIdKey     = mkPreludeMiscIdUnique 215
1360 instIdKey       = mkPreludeMiscIdUnique 216
1361 dataDIdKey      = mkPreludeMiscIdUnique 217
1362
1363 sequenceQIdKey  = mkPreludeMiscIdUnique 218
1364 tySynDIdKey      = mkPreludeMiscIdUnique 219
1365
1366 plitIdKey       = mkPreludeMiscIdUnique 220
1367 pvarIdKey       = mkPreludeMiscIdUnique 221
1368 ptupIdKey       = mkPreludeMiscIdUnique 222
1369 pconIdKey       = mkPreludeMiscIdUnique 223
1370 ptildeIdKey     = mkPreludeMiscIdUnique 224
1371 paspatIdKey     = mkPreludeMiscIdUnique 225
1372 pwildIdKey      = mkPreludeMiscIdUnique 226
1373 varIdKey        = mkPreludeMiscIdUnique 227
1374 conIdKey        = mkPreludeMiscIdUnique 228
1375 litIdKey        = mkPreludeMiscIdUnique 229
1376 appIdKey        = mkPreludeMiscIdUnique 230
1377 infixEIdKey     = mkPreludeMiscIdUnique 231
1378 lamIdKey        = mkPreludeMiscIdUnique 232
1379 tupIdKey        = mkPreludeMiscIdUnique 233
1380 doEIdKey        = mkPreludeMiscIdUnique 234
1381 compIdKey       = mkPreludeMiscIdUnique 235
1382 listExpIdKey    = mkPreludeMiscIdUnique 237
1383 condIdKey       = mkPreludeMiscIdUnique 238
1384 letEIdKey       = mkPreludeMiscIdUnique 239
1385 caseEIdKey      = mkPreludeMiscIdUnique 240
1386 infixAppIdKey   = mkPreludeMiscIdUnique 241
1387 -- 242 unallocated
1388 sectionLIdKey   = mkPreludeMiscIdUnique 243
1389 sectionRIdKey   = mkPreludeMiscIdUnique 244
1390 guardedIdKey    = mkPreludeMiscIdUnique 245
1391 normalIdKey     = mkPreludeMiscIdUnique 246
1392 bindStIdKey     = mkPreludeMiscIdUnique 247
1393 letStIdKey      = mkPreludeMiscIdUnique 248
1394 noBindStIdKey   = mkPreludeMiscIdUnique 249
1395 parStIdKey      = mkPreludeMiscIdUnique 250
1396
1397 tforallIdKey    = mkPreludeMiscIdUnique 251
1398 tvarIdKey       = mkPreludeMiscIdUnique 252
1399 tconIdKey       = mkPreludeMiscIdUnique 253
1400 tappIdKey       = mkPreludeMiscIdUnique 254
1401
1402 arrowIdKey      = mkPreludeMiscIdUnique 255
1403 tupleIdKey      = mkPreludeMiscIdUnique 256
1404 listIdKey       = mkPreludeMiscIdUnique 257
1405 namedTyConIdKey = mkPreludeMiscIdUnique 258
1406
1407 ctxtIdKey       = mkPreludeMiscIdUnique 259
1408
1409 constrIdKey     = mkPreludeMiscIdUnique 260
1410
1411 stringLIdKey    = mkPreludeMiscIdUnique 261
1412 rationalLIdKey  = mkPreludeMiscIdUnique 262
1413
1414 sigExpIdKey     = mkPreludeMiscIdUnique 263
1415
1416 strictTypeKey = mkPreludeMiscIdUnique 264
1417 strictKey = mkPreludeMiscIdUnique 265
1418 nonstrictKey = mkPreludeMiscIdUnique 266
1419 varStrictTypeKey = mkPreludeMiscIdUnique 267
1420
1421 recConstrIdKey  = mkPreludeMiscIdUnique 268
1422 infixConstrIdKey        = mkPreludeMiscIdUnique 269
1423
1424 recConIdKey     = mkPreludeMiscIdUnique 270
1425 recUpdIdKey     = mkPreludeMiscIdUnique 271
1426 precIdKey       = mkPreludeMiscIdUnique 272
1427 fieldKey        = mkPreludeMiscIdUnique 273
1428 fieldPKey       = mkPreludeMiscIdUnique 274
1429
1430
1431 -- %************************************************************************
1432 -- %*                                                                   *
1433 --              Other utilities
1434 -- %*                                                                   *
1435 -- %************************************************************************
1436
1437 -- It is rather usatisfactory that we don't have a SrcLoc
1438 addDsWarn :: SDoc -> DsM ()
1439 addDsWarn msg = dsWarn (noSrcLoc, msg)