ghc/compiler/deSugar/DsMeta.hs

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