DsMeta.hs 64 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 )
Simon Marlow's avatar
Simon Marlow committed
25
import DsUtils    ( mkListExpr, mkStringExpr, 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 217 218
repTyClD (L loc d) = putSrcSpanDs loc $
		     do { dsWarn (hang ds_msg 4 (ppr d))
			; 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 235 236 237 238 239 240 241 242 243 244 245 246 247 248
repInstD' (L loc (InstDecl ty binds _))		-- Ignore user pragmas for now
 = 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 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
      MkC str <- coreStringLit $ static
                              ++ unpackFS ch ++ " "
                              ++ unpackFS cn ++ " "
                              ++ conv_cimportspec cis
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
    conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
    conv_cimportspec (CFunction DynamicTarget) = "dynamic"
    conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
    conv_cimportspec CWrapper = "wrapper"
    static = case cis of
                 CFunction (StaticTarget _) -> "static "
                 _ -> ""

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 []

283 284
ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")

285 286 287 288
-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

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

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

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

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


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

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

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

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

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


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
361

362 363
-- 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
364
-- meta environment and gets the *new* names on Core-level as an argument
365
--
366
addTyVarBinds :: [LHsTyVarBndr Name]	         -- the binders to be added
367 368
	      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
	      -> DsM (Core (TH.Q a))
369
addTyVarBinds tvs m =
370
  do
371
    let names = map (hsTyVarName.unLoc) tvs
372
    freshNames <- mkGenSyms names
373 374 375
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
376
    wrapGenSyns freshNames term
377

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

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

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

394
repPred :: HsPred Name -> DsM (Core TH.TypeQ)
395 396
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
397
			       tys1 <- repLTys tys
398 399 400 401 402 403
			       repTapps tcon tys1
repPred (HsIParam _ _)     = 
  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"

-- 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 452
repTy (HsNumTy i)                 =
  panic "DsMeta.repTy: Can't represent number types (for generics)"
453
repTy (HsPredTy pred)             = repPred pred
454 455
repTy (HsKindSig ty kind)	  = 
  panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
456 457


458
-----------------------------------------------------------------------------
459
-- 		Expressions
460
-----------------------------------------------------------------------------
461

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

466 467 468
-- 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
469 470 471
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
repLE (L _ e) = repE e

472
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
473 474 475
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
476
	Nothing	         -> do { str <- globalVar x
477 478 479 480
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
481
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
482 483 484 485 486

	-- 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 }
487
repE (HsLam (MatchGroup [m] _)) = repLambda m
488
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
489

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

543
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
544
repE (ArithSeq _ aseq) =
545
  case aseq of
546
    From e              -> do { ds1 <- repLE e; repFrom ds1 }
547
    FromThen e1 e2      -> do 
548 549
		             ds1 <- repLE e1
			     ds2 <- repLE e2
550 551
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
552 553
			     ds1 <- repLE e1
			     ds2 <- repLE e2
554 555
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
556 557 558
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     ds3 <- repLE e3
559
			     repFromThenTo ds1 ds2 ds3
560
repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
561
repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
562
repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
563 564 565 566 567 568 569 570 571
repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _)) 
  = do { mb_val <- dsLookupMetaEnv n
       ; case mb_val of
		 Just (Splice e) -> do { e' <- dsExpr e
				       ; return (MkC e') }
		 other	     -> pprPanic "HsSplice" (ppr n) }

repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
572 573 574 575

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

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

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

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

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

624 625 626

-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
627
-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649
-- 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.

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

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


676 677 678
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
679

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

repBinds (HsIPBinds _)
  = panic "DsMeta:repBinds: can't do implicit parameters"

repBinds (HsValBinds decs)
 = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
690 691 692 693
		-- 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
694
	; ss        <- mkGenSyms bndrs
695 696 697
	; prs       <- addBinds ss (rep_val_binds decs)
	; core_list <- coreList decQTyConName 
				(de_loc (sort_by_loc prs))
698
	; return (ss, core_list) }
699

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

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
-- Since everything in a Bind is mutually recursive we need rename all
755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770
-- 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


-----------------------------------------------------------------------------
771
-- GHC allows a more general form of lambda abstraction than specified
772 773 774 775 776
-- 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.  

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

repLambda z = panic "Can't represent a guarded lambda in Template Haskell"  

  
-----------------------------------------------------------------------------
789
--			Patterns
790 791 792 793 794 795
-- 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
796
repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
797
repLPs ps = do { ps' <- mapM repLP ps ;
798
		 coreList patQTyConName ps' }
799

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

803
repP :: Pat Name -> DsM (Core TH.PatQ)
804 805 806 807 808 809 810 811
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 }
812
repP (ConPatIn dc details)
813
 = do { con_str <- lookupLOcc dc
814
      ; case details of
815 816 817
         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
                            ; ps <- sequence $ map repLP (map snd pairs)
818
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
819
                            ; fps' <- coreList fieldPatQTyConName fps
820
                            ; repPrec con_str fps' }
821 822 823
         InfixCon p1 p2 -> do { p1' <- repLP p1;
                                p2' <- repLP p2;
                                repPinfix p1' con_str p2' }
824
   }
825 826
repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
827
repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
828 829
repP other = panic "Exotic pattern inside meta brackets"

830 831 832
----------------------------------------------------------
-- Declaration ordering helpers

833
sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
834 835 836
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

837
de_loc :: [(a, b)] -> [b]
838 839
de_loc = map snd

840 841 842
----------------------------------------------------------
--	The meta-environment

843
-- A name/identifier association for fresh names of locally bound entities
844 845 846 847
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 ...

848
-- Generate a fresh name for a locally bound entity
849

850 851
mkGenSyms :: [Name] -> DsM [GenSymBind]
-- We can use the existing name.  For example:
852 853 854 855 856
--	[| \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
857
--
858 859 860 861 862 863
-- 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] }

864
	     
865
addBinds :: [GenSymBind] -> DsM a -> DsM a
866 867 868
-- 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) 
869 870 871 872
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
873 874 875
lookupLBinder :: Located Name -> DsM (Core TH.Name)
lookupLBinder (L _ n) = lookupBinder n

876
lookupBinder :: Name -> DsM (Core TH.Name)
877 878 879 880
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
881
	    other	   -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
882

883 884
-- Look up a name that is either locally bound or a global name
--
885
--  * If it is a global name, generate the "original name" representation (ie,
886 887
--   the <module>:<name> form) for the associated entity
--
888
lookupLOcc :: Located Name -> DsM (Core TH.Name)
889 890
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
891 892 893
lookupLOcc (L _ n) = lookupOcc n

lookupOcc :: Name -> DsM (Core TH.Name)
894 895 896 897 898 899 900 901
lookupOcc n
  = do {  mb_val <- dsLookupMetaEnv n ;
          case mb_val of
		Nothing         -> globalVar n
		Just (Bound x)  -> return (coreVar x)
		Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) 
    }

902 903 904 905 906 907 908 909
globalVar :: Name -> DsM (Core TH.Name)
-- Not bound by the meta-env
-- Could be top-level; or could be local
--	f x = $(g [| x |])
-- Here the x will be local
globalVar name
  | isExternalName name
  = do	{ MkC mod <- coreStringLit name_mod
Simon Marlow's avatar
Simon Marlow committed
910
        ; MkC pkg <- coreStringLit name_pkg
911
	; MkC occ <- occNameLit name
Simon Marlow's avatar
Simon Marlow committed
912
	; rep2 mk_varg [pkg,mod,occ] }
913 914 915
  | otherwise
  = do 	{ MkC occ <- occNameLit name
	; MkC uni <- coreIntLit (getKey (getUnique name))
916
	; rep2 mkNameLName [occ,uni] }
917
  where
Simon Marlow's avatar
Simon Marlow committed
918 919 920
      mod = nameModule name
      name_mod = moduleNameString (moduleName mod)
      name_pkg = packageIdString (modulePackageId mod)
921 922 923 924 925 926 927
      name_occ = nameOccName name
      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
	      | OccName.isVarOcc  name_occ = mkNameG_vName
	      | OccName.isTcOcc   name_occ = mkNameG_tcName
	      | otherwise 	           = pprPanic "DsMeta.globalVar" (ppr name)

lookupType :: Name 	-- Name of type constructor (e.g. TH.ExpQ)
928 929
	   -> DsM Type	-- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
930
		          return (mkTyConApp tc []) }
931

932
wrapGenSyns :: [GenSymBind] 
933
	    -> Core (TH.Q a) -> DsM (Core (TH.Q a))
934 935 936 937
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))
938

939
wrapGenSyns binds body@(MkC b)
940 941
  = do  { var_ty <- lookupType nameTyConName
	; go var_ty binds }
942
  where
943