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