ghc/compiler/deSugar/DsMeta.hs

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