ghc/compiler/deSugar/DsMeta.hs

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