DsMeta.hs 64.8 KB
Newer Older
1 2 3 4 5
-----------------------------------------------------------------------------
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
6 7 8 9 10
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
-- in prelude/PrelNames.  It's much more convenient to do it here, becuase
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
11 12 13
-----------------------------------------------------------------------------


14 15
module DsMeta( dsBracket, 
	       templateHaskellNames, qTyConName, nameTyConName,
16
	       liftName, expQTyConName, decQTyConName, typeQTyConName,
17 18
	       decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
	        ) where
19 20 21 22 23

#include "HsVersions.h"

import {-# SOURCE #-}	DsExpr ( dsExpr )

24
import MatchLit	  ( dsLit )
25
import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
26 27
import DsMonad

28
import qualified Language.Haskell.TH as TH
29

30
import HsSyn
31
import Class (FunDep)
32
import PrelNames  ( rationalTyConName, integerTyConName, negateName )
33
import OccName	  ( isDataOcc, isTvOcc, occNameString )
34 35 36 37
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
38
import qualified OccName
39

Simon Marlow's avatar
Simon Marlow committed
40 41
import Module	  ( Module, mkModule, moduleNameString, moduleName,
                    modulePackageId, mkModuleNameFS )
42
import Id         ( Id, mkLocalId )
43
import OccName	  ( mkOccNameFS )
44 45
import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
		    isExternalName, getSrcLoc )
46
import NameEnv
47
import Type       ( Type, mkTyConApp )
48
import TcType	  ( tcTyConAppArgs )
49 50
import TyCon	  ( tyConName )
import TysWiredIn ( parrTyCon )
51 52
import CoreSyn
import CoreUtils  ( exprType )
53
import SrcLoc	  ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
Simon Marlow's avatar
Simon Marlow committed
54
import PackageConfig ( thPackageId, packageIdString )
55
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
56
import BasicTypes ( isBoxed ) 
57
import Outputable
58
import Bag	  ( bagToList, unionManyBags )
59
import FastString ( unpackFS )
60
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
61

Simon Marlow's avatar
Simon Marlow committed
62
import Maybe	  ( catMaybes )
63
import Monad ( zipWithM )
64
import List ( sortBy )
65 66 67
 
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
68
-- Returns a CoreExpr of type TH.ExpQ
69 70 71
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

72 73
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
74
  where
75
    new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
76

77
    do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
78 79
    do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
80
    do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
81
    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97

{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


98 99 100 101
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

102
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
103
repTopDs group
104
 = do { let { bndrs = map unLoc (groupBinders group) } ;
105
	ss <- mkGenSyms bndrs ;
106

107 108 109 110 111
	-- Bind all the names mainly to avoid repeated use of explicit strings.
	-- Thus	we get
	--	do { t :: String <- genSym "T" ;
	--	     return (Data t [] ...more t's... }
	-- The other important reason is that the output must mention
112
	-- only "T", not "Foo:T" where Foo is the current module
113 114

	
115
	decls <- addBinds ss (do {
116
			val_ds  <- rep_val_binds (hs_valds group) ;
117
			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
118
			inst_ds <- mapM repInstD' (hs_instds group) ;
119
			for_ds <- mapM repForD (hs_fords group) ;
120
			-- more needed
121
			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
122

123
	decl_ty <- lookupType decQTyConName ;
124
	let { core_list = coreList' decl_ty decls } ;
125 126 127

	dec_ty <- lookupType decTyConName ;
	q_decs  <- repSequenceQ dec_ty core_list ;
128 129

	wrapNongenSyms ss q_decs
130 131 132 133 134
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
135
-- Collect the binders of a Group
136
  = collectHsValBinders val_decls ++
137
    [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
138
    [n | L _ (ForeignImport n _ _) <- foreign_decls]
139 140


141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
{- 	Note [Binders and occurrences]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we desugar [d| data T = MkT |]
we want to get
	Data "T" [] [Con "MkT" []] []
and *not*
	Data "Foo:T" [] [Con "Foo:MkT" []] []
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
	Data "T79" ....

But if we see this:
	data T = MkT 
	foo = reifyDecl T

then we must desugar to
	foo = Data "Foo:T" [] [Con "Foo:MkT" []] []

159 160
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
161 162 163 164
in repTyClD and repC.

-}

165
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
166

167 168 169 170
repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = cons, tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
171
        dec <- addTyVarBinds tvs $ \bndrs -> do {
172
      	       cxt1    <- repLContext cxt ;
173
               cons1   <- mapM repC cons ;
174
      	       cons2   <- coreList conQTyConName cons1 ;
175
      	       derivs1 <- repDerivs mb_derivs ;
176 177
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
178
        return $ Just (loc, dec) }
179

180 181 182 183
repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = [con], tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
184
        dec <- addTyVarBinds tvs $ \bndrs -> do {
185
      	       cxt1   <- repLContext cxt ;
186 187
               con1   <- repC con ;
      	       derivs1 <- repDerivs mb_derivs ;
188 189
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
190 191
        return $ Just (loc, dec) }

192 193
repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
194
        dec <- addTyVarBinds tvs $ \bndrs -> do {
195
	       ty1     <- repLTy ty ;
196 197
	       bndrs1  <- coreList nameTyConName bndrs ;
	       repTySyn tc1 bndrs1 ty1 } ;
198
 	return (Just (loc, dec)) }
199

200
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
201
		      tcdTyVars = tvs, 
202
		      tcdFDs = fds,
203 204
		      tcdSigs = sigs, tcdMeths = meth_binds }))
 = do { cls1 <- lookupLOcc cls ;		-- See note [Binders and occurrences] 
205
    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
206
 		  cxt1   <- repLContext cxt ;
207
 		  sigs1  <- rep_sigs sigs ;
208
 		  binds1 <- rep_binds meth_binds ;
209
	          fds1 <- repLFunDeps fds;
210
 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
211
	          bndrs1 <- coreList nameTyConName bndrs ;
212
 		  repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
213
    	return $ Just (loc, dec) }
214 215

-- Un-handled cases
216
repTyClD (L loc d) = putSrcSpanDs loc $
217
		     do { warnDs (hang ds_msg 4 (ppr d))
218
			; return Nothing }
219

220 221 222 223 224 225 226 227 228 229 230 231 232
-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
repLFunDeps fds = do fds' <- mapM repLFunDep fds
                     fdList <- coreList funDepTyConName fds'
                     return fdList

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                               ys' <- mapM lookupBinder ys
                               xs_list <- coreList nameTyConName xs'
                               ys_list <- coreList nameTyConName ys'
                               repFunDep xs_list ys_list
233

234
repInstD' (L loc (InstDecl ty binds _ _))		-- Ignore user pragmas for now
235 236 237 238 239 240 241 242 243 244 245 246 247 248
 = do	{ i <- addTyVarBinds tvs $ \tv_bndrs ->
		-- We must bring the type variables into scope, so their occurrences
		-- don't fail,  even though the binders don't appear in the resulting 
		-- data structure
		do {  cxt1 <- repContext cxt
		   ; inst_ty1 <- repPred (HsClassP cls tys)
		   ; ss <- mkGenSyms (collectHsBindBinders binds)
		   ; binds1 <- addBinds ss (rep_binds binds)
		   ; decls1 <- coreList decQTyConName binds1
		   ; decls2 <- wrapNongenSyms ss decls1
		   -- wrapNonGenSyms: do not clone the class op names!
		   -- They must be called 'op' etc, not 'op34'
		   ; repInst cxt1 inst_ty1 decls2 }

249
	; return (loc, i)}
250
 where
251
   (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
252

253
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
254
repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
255 256 257 258
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
259
      cis' <- conv_cimportspec cis
260 261 262
      MkC str <- coreStringLit $ static
                              ++ unpackFS ch ++ " "
                              ++ unpackFS cn ++ " "
263
                              ++ cis'
264 265 266
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
267 268 269 270
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
    conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
    conv_cimportspec CWrapper = return "wrapper"
271 272 273
    static = case cis of
                 CFunction (StaticTarget _) -> "static "
                 _ -> ""
274
repForD decl = notHandled "Foreign declaration" (ppr decl)
275 276 277 278 279 280 281 282 283 284

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []

285 286
ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")

287 288 289 290
-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

291
repC :: LConDecl Name -> DsM (Core TH.ConQ)
292
repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _))
293
  = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
294
	 repConstr con1 details }
295
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
296
  = do { addTyVarBinds tvs $ \bndrs -> do {
297
             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
298 299 300 301 302
             ctxt' <- repContext ctxt;
             bndrs' <- coreList nameTyConName bndrs;
             rep2 forallCName [unC bndrs', unC ctxt', unC c']
         }
       }
303
repC (L loc con_decl)		-- GADTs
304 305
  = putSrcSpanDs loc $
    notHandled "GADT declaration" (ppr con_decl) 
306

307
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
308 309 310
repBangTy ty= do 
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
311
  rep2 strictTypeName [s, t]
312 313 314 315
  where 
    (str, ty') = case ty of
		   L _ (HsBangTy _ ty) -> (isStrictName,  ty)
		   other	       -> (notStrictName, ty)
316 317 318 319 320

-------------------------------------------------------
-- 			Deriving clause
-------------------------------------------------------

321
repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
322
repDerivs Nothing = coreList nameTyConName []
323
repDerivs (Just ctxt)
324
  = do { strs <- mapM rep_deriv ctxt ; 
325
	 coreList nameTyConName strs }
326
  where
327
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
328
	-- Deriving clauses must have the simple H98 form
329
    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
330
    rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
331 332 333 334 335 336


-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

337
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
338 339 340
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

341
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
342
	-- We silently ignore ones we don't recognise
343
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
344 345
		     return (concat sigs1) }

346
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
347 348
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
349 350
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
rep_sig other		        = return []
351

352 353 354
rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
		       ty1 <- repLTy ty ; 
355
		       sig <- repProto nm1 ty1 ;
356
		       return [(loc, sig)] }
357 358 359 360 361


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
362

363 364
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
365
-- meta environment and gets the *new* names on Core-level as an argument
366
--
367
addTyVarBinds :: [LHsTyVarBndr Name]	         -- the binders to be added
368 369
	      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
	      -> DsM (Core (TH.Q a))
370
addTyVarBinds tvs m =
371
  do
372
    let names = map (hsTyVarName.unLoc) tvs
373
    freshNames <- mkGenSyms names
374 375 376
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
377
    wrapGenSyns freshNames term
378

379 380
-- represent a type context
--
381 382 383
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

384
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
385
repContext ctxt = do 
386
	            preds    <- mapM repLPred ctxt
387
		    predList <- coreList typeQTyConName preds
388
		    repCtxt predList
389

390 391
-- represent a type predicate
--
392 393 394
repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
repLPred (L _ p) = repPred p

395
repPred :: HsPred Name -> DsM (Core TH.TypeQ)
396 397
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
398
			       tys1 <- repLTys tys
399
			       repTapps tcon tys1
400
repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
401 402 403

-- yield the representation of a list of types
--
404 405
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
406

407 408
-- represent a type
--
409 410 411
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

412 413 414
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy (HsForAllTy _ tvs ctxt ty)  = 
  addTyVarBinds tvs $ \bndrs -> do
415 416
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
417 418
    bndrs1 <- coreList nameTyConName bndrs
    repTForall bndrs1 ctxt1 ty1
419

420
repTy (HsTyVar n)
421 422 423 424 425 426 427
  | isTvOcc (nameOccName n)       = do 
				      tv1 <- lookupBinder n
				      repTvar tv1
  | otherwise		          = do 
				      tc1 <- lookupOcc n
				      repNamedTyCon tc1
repTy (HsAppTy f a)               = do 
428 429
				      f1 <- repLTy f
				      a1 <- repLTy a
430 431
				      repTapp f1 a1
repTy (HsFunTy f a)               = do 
432 433
				      f1   <- repLTy f
				      a1   <- repLTy a
434 435 436
				      tcon <- repArrowTyCon
				      repTapps tcon [f1, a1]
repTy (HsListTy t)		  = do
437
				      t1   <- repLTy t
438 439 440
				      tcon <- repListTyCon
				      repTapp tcon t1
repTy (HsPArrTy t)                = do
441
				      t1   <- repLTy t
442
				      tcon <- repTy (HsTyVar (tyConName parrTyCon))
443 444
				      repTapp tcon t1
repTy (HsTupleTy tc tys)	  = do
445
				      tys1 <- repLTys tys 
446 447
				      tcon <- repTupleTyCon (length tys)
				      repTapps tcon tys1
448 449 450
repTy (HsOpTy ty1 n ty2) 	  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
					   `nlHsAppTy` ty2)
repTy (HsParTy t)  	       	  = repLTy t
451
repTy (HsPredTy pred)             = repPred pred
452 453
repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
repTy ty			  = notHandled "Exotic form of type" (ppr ty)
454 455


456
-----------------------------------------------------------------------------
457
-- 		Expressions
458
-----------------------------------------------------------------------------
459

460 461 462
repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
repLEs es = do { es'  <- mapM repLE es ;
		 coreList expQTyConName es' }
463

464 465 466
-- FIXME: some of these panics should be converted into proper error messages
--	  unless we can make sure that constructs, which are plainly not
--	  supported in TH already lead to error messages at an earlier stage
467
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
468
repLE (L loc e) = putSrcSpanDs loc (repE e)
469

470
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
471 472 473
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
474
	Nothing	         -> do { str <- globalVar x
475 476 477 478
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
479
repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e)
480 481 482 483 484

	-- Remember, we're desugaring renamer output here, so
	-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
485
repE (HsLam (MatchGroup [m] _)) = repLambda m
486
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
487

488
repE (OpApp e1 op fix e2) =
489 490 491
  do { arg1 <- repLE e1; 
       arg2 <- repLE e2; 
       the_op <- repLE op ;
492
       repInfixApp arg1 the_op arg2 } 
493
repE (NegApp x nm)        = do
494
			      a         <- repLE x
495 496
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
497 498 499
repE (HsPar x)            = repLE x
repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } 
repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } 
500 501 502
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
				       ; ms2 <- mapM repMatchTup ms
				       ; repCaseE arg (nonEmptyCoreList ms2) }
503 504 505 506
repE (HsIf x y z)         = do
			      a <- repLE x
			      b <- repLE y
			      c <- repLE z
507 508
			      repCond a b c
repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
509
			       ; e2 <- addBinds ss (repLE e)
510
			       ; z <- repLetE ds e2
511
			       ; wrapGenSyns ss z }
512
-- FIXME: I haven't got the types here right yet
513
repE (HsDo DoExpr sts body ty) 
514
 = do { (ss,zs) <- repLSts sts; 
515
	body'	<- addBinds ss $ repLE body;
516 517
	ret	<- repNoBindSt body';	
        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
518
        wrapGenSyns ss e }
519
repE (HsDo ListComp sts body ty) 
520
 = do { (ss,zs) <- repLSts sts; 
521
	body'	<- addBinds ss $ repLE body;
522 523
	ret	<- repNoBindSt body';	
        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
524
        wrapGenSyns ss e }
525
repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
526
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } 
527 528
repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed) 
529
  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
530
  | otherwise		  = notHandled "Unboxed tuples" (ppr e)
531
repE (RecordCon c _ flds)
532
 = do { x <- lookupLOcc c;
533 534
        fs <- repFields flds;
        repRecCon x fs }
535
repE (RecordUpd e flds _ _)
536
 = do { x <- repLE e;
537 538
        fs <- repFields flds;
        repRecUpd x fs }
539

540
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
541
repE (ArithSeq _ aseq) =
542
  case aseq of
543
    From e              -> do { ds1 <- repLE e; repFrom ds1 }
544
    FromThen e1 e2      -> do 
545 546
		             ds1 <- repLE e1
			     ds2 <- repLE e2
547 548
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
549 550
			     ds1 <- repLE e1
			     ds2 <- repLE e2
551 552
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
553 554 555
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     ds3 <- repLE e3
556
			     repFromThenTo ds1 ds2 ds3
557 558 559 560 561
repE (HsSpliceE (HsSplice n _)) 
  = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
		 Just (Splice e) -> do { e' <- dsExpr e
				       ; return (MkC e') }
562 563
		 other -> pprPanic "HsSplice" (ppr n) }
			-- Should not happen; statically checked
564

565 566 567 568 569
repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e 			 = notHandled "Expression form" (ppr e)
570 571 572 573

-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt, 

574
repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ) 
575
repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
576
  do { ss1 <- mkGenSyms (collectPatBinders p) 
577
     ; addBinds ss1 $ do {
578
     ; p1 <- repLP p
579
     ; (ss2,ds) <- repBinds wheres
580 581 582
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
583
     ; wrapGenSyns (ss1++ss2) match }}}
584
repMatchTup other = panic "repMatchTup: case alt with more than one arg"
585

586
repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
587
repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
588
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
589
     ; addBinds ss1 $ do {
590
       ps1 <- repLPs ps
591
     ; (ss2,ds) <- repBinds wheres
592 593 594
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
595
     ; wrapGenSyns (ss1++ss2) clause }}}
596

597
repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
598
repGuards [L _ (GRHS [] e)]
599
  = do {a <- repLE e; repNormal a }
600
repGuards other 
601 602 603 604
  = do { zs <- mapM process other;
     let {(xs, ys) = unzip zs};
	 gd <- repGuarded (nonEmptyCoreList ys);
     wrapGenSyns (concat xs) gd }
605
  where 
606
    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
607
    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
608 609
           = do { x <- repLNormalGE e1 e2;
                  return ([], x) }
610
    process (L _ (GRHS ss rhs))
611
           = do (gs, ss') <- repLSts ss
612
		rhs' <- addBinds gs $ repLE rhs
613
                g <- repPatGE (nonEmptyCoreList ss') rhs'
614
                return (gs, g)
615

616
repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
617
repFields flds = do
618 619
        fnames <- mapM lookupLOcc (map fst flds)
        es <- mapM repLE (map snd flds)
620 621
        fs <- zipWithM repFieldExp fnames es
        coreList fieldExpQTyConName fs
622

623 624 625

-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
626
-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648
-- First gensym new names for every variable in any of the patterns.
-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
-- if variables didn't shaddow, the static gensym wouldn't be necessary
-- and we could reuse the original names (x and x).
--
-- do { x'1 <- gensym "x"
--    ; x'2 <- gensym "x"   
--    ; doE [ BindSt (pvar x'1) [| f 1 |]
--          , BindSt (pvar x'2) [| f x |] 
--          , NoBindSt [| g x |] 
--          ]
--    }

-- The strategy is to translate a whole list of do-bindings by building a
-- bigger environment, and a bigger set of meta bindings 
-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
-- of the expressions within the Do
      
-----------------------------------------------------------------------------
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.

649 650 651
repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)

652
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
653
repSts (BindStmt p e _ _ : ss) =
654
   do { e2 <- repLE e 
655
      ; ss1 <- mkGenSyms (collectPatBinders p) 
656
      ; addBinds ss1 $ do {
657
      ; p1 <- repLP p; 
658 659 660 661
      ; (ss2,zs) <- repSts ss
      ; z <- repBindSt p1 e2
      ; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
662
   do { (ss1,ds) <- repBinds bs
663 664 665
      ; z <- repLetSt ds
      ; (ss2,zs) <- addBinds ss1 (repSts ss)
      ; return (ss1++ss2, z : zs) } 
666
repSts (ExprStmt e _ _ : ss) =       
667
   do { e2 <- repLE e
668 669 670
      ; z <- repNoBindSt e2 
      ; (ss2,zs) <- repSts ss
      ; return (ss2, z : zs) }
671 672
repSts []    = return ([],[])
repSts other = notHandled "Exotic statement" (ppr other)
673 674


675 676 677
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
678

679 680 681 682 683
repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) 
repBinds EmptyLocalBinds
  = do	{ core_list <- coreList decQTyConName []
	; return ([], core_list) }

684
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
685 686 687

repBinds (HsValBinds decs)
 = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
688 689 690 691
		-- No need to worrry about detailed scopes within
		-- the binding group, because we are talking Names
		-- here, so we can safely treat it as a mutually 
		-- recursive group
692
	; ss        <- mkGenSyms bndrs
693 694 695
	; prs       <- addBinds ss (rep_val_binds decs)
	; core_list <- coreList decQTyConName 
				(de_loc (sort_by_loc prs))
696
	; return (ss, core_list) }
697

698
rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
699
-- Assumes: all the binders of the binding are alrady in the meta-env
700 701
rep_val_binds (ValBindsOut binds sigs)
 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
702
      ;	core2 <- rep_sigs' sigs
703
      ;	return (core1 ++ core2) }
704 705
rep_val_binds (ValBindsOut binds sigs)
 = panic "rep_val_binds: ValBindsOut"
706

707
rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
708 709 710 711 712
rep_binds binds = do { binds_w_locs <- rep_binds' binds
		     ; return (de_loc (sort_by_loc binds_w_locs)) }

rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_binds' binds = mapM rep_bind (bagToList binds)
713

714
rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
715
-- Assumes: all the binders of the binding are alrady in the meta-env
716 717 718 719

-- Note GHC treats declarations of a variable (not a pattern) 
-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
-- with an empty list of patterns
720 721
rep_bind (L loc (FunBind { fun_id = fn, 
			   fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
722
 = do { (ss,wherecore) <- repBinds wheres
723
	; guardcore <- addBinds ss (repGuards guards)
724 725 726 727 728
	; fn'  <- lookupLBinder fn
	; p    <- repPvar fn'
	; ans  <- repVal p guardcore wherecore
	; ans' <- wrapGenSyns ss ans
	; return (loc, ans') }
729

730
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
731
 =   do { ms1 <- mapM repClauseTup ms
732
	; fn' <- lookupLBinder fn
733
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
734
        ; return (loc, ans) }
735

736
rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
737
 =   do { patcore <- repLP pat 
738
        ; (ss,wherecore) <- repBinds wheres
739
	; guardcore <- addBinds ss (repGuards guards)
740 741 742
        ; ans  <- repVal patcore guardcore wherecore
	; ans' <- wrapGenSyns ss ans
        ; return (loc, ans') }
743

744
rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
745
 =   do { v' <- lookupBinder v 
746
	; e2 <- repLE e
747 748
        ; x <- repNormal e2
        ; patcore <- repPvar v'
749
	; empty_decls <- coreList decQTyConName [] 
750
        ; ans <- repVal patcore x empty_decls
751
        ; return (srcLocSpan (getSrcLoc v), ans) }
752

753 754
rep_bind other = panic "rep_bind: AbsBinds"

755
-----------------------------------------------------------------------------
756
-- Since everything in a Bind is mutually recursive we need rename all
757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772
-- all the variables simultaneously. For example: 
-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
-- do { f'1 <- gensym "f"
--    ; g'2 <- gensym "g"
--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
--      ]}
-- This requires collecting the bindings (f'1 <- gensym "f"), and the 
-- environment ( f |-> f'1 ) from each binding, and then unioning them 
-- together. As we do this we collect GenSymBinds's which represent the renamed 
-- variables bound by the Bindings. In order not to lose track of these 
-- representations we build a shadow datatype MB with the same structure as 
-- MonoBinds, but which has slots for the representations


-----------------------------------------------------------------------------
773
-- GHC allows a more general form of lambda abstraction than specified
774 775 776 777 778
-- by Haskell 98. In particular it allows guarded lambda's like : 
-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.  

779
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
780
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
781
 = do { let bndrs = collectPatsBinders ps ;
782
      ; ss  <- mkGenSyms bndrs
783
      ; lam <- addBinds ss (
784
		do { xs <- repLPs ps; body <- repLE e; repLam xs body })
785
      ; wrapGenSyns ss lam }
786

787
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
788 789 790

  
-----------------------------------------------------------------------------
791
--			Patterns
792 793 794 795 796 797
-- repP deals with patterns.  It assumes that we have already
-- walked over the pattern(s) once to collect the binders, and 
-- have extended the environment.  So every pattern-bound 
-- variable should already appear in the environment.

-- Process a list of patterns
798
repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
799
repLPs ps = do { ps' <- mapM repLP ps ;
800
		 coreList patQTyConName ps' }
801

802
repLP :: LPat Name -> DsM (Core TH.PatQ)
803
repLP (L _ p) = repP p
804

805
repP :: Pat Name -> DsM (Core TH.PatQ)
806 807 808 809 810 811 812 813
repP (WildPat _)       = repPwild 
repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p)        = repLP p 
repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
814
repP (ConPatIn dc details)
815
 = do { con_str <- lookupLOcc dc
816
      ; case details of
817
         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
818 819
         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
                            ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
820
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
821
                            ; fps' <- coreList fieldPatQTyConName fps
822
                            ; repPrec con_str fps' }
823 824 825
         InfixCon p1 p2 -> do { p1' <- repLP p1;
                                p2' <- repLP p2;
                                repPinfix p1' con_str p2' }
826
   }
827
repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
828 829 830 831 832 833 834 835 836 837
repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
	-- The problem is to do with scoped type variables.
	-- To implement them, we have to implement the scoping rules
	-- here in DsMeta, and I don't want to do that today!
	--	 do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
	--	repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
	--	repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]

repP other = notHandled "Exotic pattern" (ppr other)
838

839 840 841
----------------------------------------------------------
-- Declaration ordering helpers

842
sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
843 844 845
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

846
de_loc :: [(a, b)] -> [b]
847 848
de_loc = map snd

849 850 851
----------------------------------------------------------
--	The meta-environment

852
-- A name/identifier association for fresh names of locally bound entities
853 854 855 856
type GenSymBind = (Name, Id)	-- Gensym the string and bind it to the Id
				-- I.e.		(x, x_id) means
				--	let x_id = gensym "x" in ...

857
-- Generate a fresh name for a locally bound entity
858

859 860
mkGenSyms :: [Name] -> DsM [GenSymBind]
-- We can use the existing name.  For example:
861 862 863 864 865
--	[| \x_77 -> x_77 + x_77 |]
-- desugars to
--	do { x_77 <- genSym "x"; .... }
-- We use the same x_77 in the desugared program, but with the type Bndr
-- instead of Int
866
--
867 868 869 870 871 872
-- We do make it an Internal name, though (hence localiseName)
--
-- Nevertheless, it's monadic because we have to generate nameTy
mkGenSyms ns = do { var_ty <- lookupType nameTyConName
		  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }

873
	     
874
addBinds :: [GenSymBind] -> DsM a -> DsM a
875 876 877
-- Add a list of fresh names for locally bound entities to the 
-- meta environment (which is part of the state carried around 
-- by the desugarer monad) 
878 879 880 881
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
882 883 884
lookupLBinder :: Located Name -> DsM (Core TH.Name)
lookupLBinder (L _ n) = lookupBinder n

885
lookupBinder :: Name -> DsM (Core TH.Name)
886 887 888 889
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
890 891 892
	    other	   -> failWithDs msg }
  where
    msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
893

894 895
-- Look up a name that is either locally bound or a global name
--
896
--  * If it is a global name, generate the "original name" representation (ie,
897 898
--   the <module>:<name> form) for the associated entity
--
899
lookupLOcc :: Located Name -> DsM (Core TH.Name)
900 901
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
902 903 904
lookupLOcc (L _ n) = lookupOcc n

lookupOcc :: Name -> DsM (Core TH.Name)
905 906 907 908 909 910 911 912
lookupOcc n
  = do {  mb_val <- dsLookupMetaEnv n ;
          case mb_val of
		Nothing         -> globalVar n
		Just (