TcSplice.lhs 36.7 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
4
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
5
6

TcSplice: Template Haskell splices
7
8

\begin{code}
9
{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
10
11
12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14
15
-- for details

16
module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
17
18
                 lookupThName_maybe,
                 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
19
20
21

#include "HsVersions.h"

22
23
import HscMain
import TcRnDriver
24
25
26
	-- These imports are the reason that TcSplice 
	-- is very high up the module hierarchy

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
import HsSyn
import Convert
import RnExpr
import RnEnv
import RdrName
import RnTypes
import TcExpr
import TcHsSyn
import TcSimplify
import TcUnify
import TcType
import TcEnv
import TcMType
import TcHsType
import TcIface
import TypeRep
import Name
import NameEnv
45
import PrelNames
46
import HscTypes
47
import OccName
48
49
import Var
import Module
50
import Annotations
51
import TcRnMonad
52
import Class
53
import Inst
54
55
56
57
58
59
60
61
import TyCon
import DataCon
import Id
import IdInfo
import TysWiredIn
import DsMeta
import DsExpr
import DsMonad hiding (Splice)
62
import Serialized
63
64
import ErrUtils
import SrcLoc
65
import Outputable
66
import Unique
67
import Maybe
68
69
70
import BasicTypes
import Panic
import FastString
71
import Exception
72

73
74
75
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
76

77
78
79
80
81
#ifdef GHCI
-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
import GHC.Desugar      ( AnnotationWrapper(..) )
#endif

82
import GHC.Exts		( unsafeCoerce#, Int#, Int(..) )
83
import System.IO.Error
84
85
\end{code}

86
87
88
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Imported things are impLevel (= 0)
89
90
91
92

* In GHCi, variables bound by a previous command are treated
  as impLevel, because we have bytecode for them.

93
* Variables are bound at the "current level"
94

95
* The current level starts off at topLevel (= 1)
96

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
* The level is decremented by splicing $(..)
	       incremented by brackets [| |]
	       incremented by name-quoting 'f

When a variable is used, we compare 
	bind:  binding level, and
	use:   current level at usage site

  Generally
	bind > use	Always error (bound later than used)
			[| \x -> $(f x) |]
			
	bind = use	Always OK (bound same stage as used)
			[| \x -> $(f [| x |]) |]

	bind < use	Inside brackets, it depends
			Inside splice, OK
			Inside neither, OK

  For (bind < use) inside brackets, there are three cases:
    - Imported things	OK	f = [| map |]
    - Top-level things	OK	g = [| f |]
    - Non-top-level 	Only if there is a liftable instance
				h = \(x:Int) -> [| x |]

122
123
See Note [What is a top-level Id?]

124
125
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
126
127
128
A quoted name 'n is a bit like a quoted expression [| n |], except that we 
have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
the use-level to account for the brackets, the cases are:
129

130
131
132
133
134
135
136
137
	bind > use			Error
	bind = use			OK
	bind < use	
		Imported things		OK
		Top-level things	OK
		Non-top-level		Error

See Note [What is a top-level Id?] in TcEnv.  Examples:
138
139
140
141
142
143
144
145
146
147
148

  f 'map	-- OK; also for top-level defns of this module

  \x. f 'x	-- Not ok (whereas \x. f [| x |] might have been ok, by
		--				 cross-stage lifting

  \y. [| \x. $(f 'y) |]	-- Not ok (same reason)

  [| \x. $(f 'x) |]	-- OK


149
150
151
152
153
154
155
156
157
158
159
160
161
162
Note [What is a top-level Id?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the level-control criteria above, we need to know what a "top level Id" is.
There are three kinds:
  * Imported from another module		(GlobalId, ExternalName)
  * Bound at the top level of this module	(ExternalName)
  * In GHCi, bound by a previous stmt		(GlobalId)
It's strange that there is no one criterion tht picks out all three, but that's
how it is right now.  (The obvious thing is to give an ExternalName to GHCi Ids 
bound in an earlier Stmt, but what module would you choose?  See 
Note [Interactively-bound Ids in GHCi] in TcRnDriver.)

The predicate we use is TcEnv.thTopLevelId.

163
164
165
166
167
168
169
170

%************************************************************************
%*									*
\subsection{Main interface + stubs for the non-GHCI case
%*									*
%************************************************************************

\begin{code}
171
tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
172
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
173
tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
174
kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
175
	-- None of these functions add constraints to the LIE
176

177
178
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)

179
180
runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
runQuasiQuotePat  :: HsQuasiQuote Name -> TcM (LPat RdrName)
181
runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
182

183
#ifndef GHCI
184
185
186
187
tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
kcSpliceType  x   = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
188

189
190
lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)

191
192
runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
runQuasiQuotePat  q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
193
runAnnotation   _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
194
195
196
197
198
#else
\end{code}

%************************************************************************
%*									*
199
\subsection{Quoting an expression}
200
201
202
%*									*
%************************************************************************

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
203
204
205
206
207
208
209
210
211
212
213
214
Note [Handling brackets]
~~~~~~~~~~~~~~~~~~~~~~~~
Source:		f = [| Just $(g 3) |]
  The [| |] part is a HsBracket

Typechecked:	f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
  The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
  The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression

Desugared:	f = do { s7 <- g Int 3
		       ; return (ConE "Data.Maybe.Just" s7) }

215
\begin{code}
216
217
218
219
220
221
222
tcBracket brack res_ty 
  = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
                   2 (ppr brack)) $
    do { level <- getStage
       ; case bracketOK level of {
 	   Nothing         -> failWithTc (illegalBracket level) ;
	   Just next_level -> do {
223
224
225
226

   	-- Typecheck expr to make sure it is valid,
	-- but throw away the results.  We'll type check
	-- it again when we actually use it.
227
228
229
          recordThUse
       ; pending_splices <- newMutVar []
       ; lie_var <- getLIEVar
230

231
232
233
       ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
                                    (getLIE (tc_bracket next_level brack))
       ; tcSimplifyBracket lie
234

235
	-- Make the expected type have the right shape
236
       ; boxyUnify meta_ty res_ty
237
238

	-- Return the original expression, not the type-decorated one
239
240
       ; pendings <- readMutVar pending_splices
       ; return (noLoc (HsBracketOut brack pendings)) }}}
241

242
243
tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
tc_bracket use_lvl (VarBr name) 	-- Note [Quoting names]
244
245
246
  = do	{ thing <- tcLookup name
	; case thing of
    	    AGlobal _ -> return ()
247
248
249
    	    ATcId { tct_level = bind_lvl, tct_id = id }
		| thTopLevelId id	-- C.f thTopLevelId case of
		-> keepAliveTc id 	--     TcExpr.thBrackId
250
		| otherwise
251
		-> do { checkTc (use_lvl == bind_lvl)
252
				(quotedNameStageErr name) }
253
	    _ -> pprPanic "th_bracket" (ppr name)
254
255
256

	; tcMetaTy nameTyConName 	-- Result type is Var (not Q-monadic)
	}
257

258
tc_bracket _ (ExpBr expr) 
259
  = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
260
	; tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
261
	; tcMetaTy expQTyConName }
262
	-- Result type is Expr (= Q Exp)
263

264
tc_bracket _ (TypBr typ) 
265
  = do	{ tcHsSigTypeNC ThBrackCtxt typ
266
	; tcMetaTy typeQTyConName }
267
268
	-- Result type is Type (= Q Typ)

269
tc_bracket _ (DecBr decls)
270
  = do	{  tcTopSrcDecls emptyModDetails decls
271
272
273
	-- Typecheck the declarations, dicarding the result
	-- We'll get all that stuff later, when we splice it in

274
275
276
	; decl_ty <- tcMetaTy decTyConName
	; q_ty    <- tcMetaTy qTyConName
	; return (mkAppTy q_ty (mkListTy decl_ty))
277
	-- Result type is Q [Dec]
278
    }
279

280
tc_bracket _ (PatBr _)
Ian Lynagh's avatar
Ian Lynagh committed
281
  = failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
282

283
quotedNameStageErr :: Name -> SDoc
284
quotedNameStageErr v 
Ian Lynagh's avatar
Ian Lynagh committed
285
286
  = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
	, ptext (sLit "must be used at the same stage at which is is bound")]
287
288
\end{code}

289

290
291
292
293
294
295
%************************************************************************
%*									*
\subsection{Splicing an expression}
%*									*
%************************************************************************

296
\begin{code}
297
tcSpliceExpr (HsSplice name expr) res_ty
298
299
  = setSrcSpan (getLoc expr) 	$ do
    level <- getStage
300
301
302
303
    case spliceOK level of {
	Nothing 	-> failWithTc (illegalSplice level) ;
	Just next_level -> 

304
     case level of {
305
	Comp _ 		       -> do { e <- tcTopSplice expr res_ty
306
307
				     ; return (unLoc e) } ;
	Brack _ ps_var lie_var -> do
308
309

	-- A splice inside brackets
310
  	-- NB: ignore res_ty, apart from zapping it to a mono-type
311
312
313
314
	-- e.g.   [| reverse $(h 4) |]
	-- Here (h 4) :: Q Exp
	-- but $(h 4) :: forall a.a 	i.e. anything!

315
316
317
318
319
320
      unBox res_ty
      meta_exp_ty <- tcMetaTy expQTyConName
      expr' <- setStage (Splice next_level) (
                 setLIEVar lie_var    $
                 tcMonoExpr expr meta_exp_ty
               )
321
322

	-- Write the pending splice into the bucket
323
324
      ps <- readMutVar ps_var
      writeMutVar ps_var ((name,expr') : ps)
325

326
      return (panic "tcSpliceExpr")	-- The returned expression is ignored
327
328

     ; Splice {} -> panic "tcSpliceExpr Splice"
329
     }} 
330
331
332
333
334

-- tcTopSplice used to have this:
-- Note that we do not decrement the level (to -1) before 
-- typechecking the expression.  For example:
--	f x = $( ...$(g 3) ... )
335
-- The recursive call to tcMonoExpr will simply expand the 
336
337
-- inner escape before dealing with the outer one

338
tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
339
340
tcTopSplice expr res_ty = do
    meta_exp_ty <- tcMetaTy expQTyConName
341

342
343
        -- Typecheck the expression
    zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
344

345
346
347
348
349
        -- Run the expression
    traceTc (text "About to run" <+> ppr zonked_q_expr)
    expr2 <- runMetaE convertToHsExpr zonked_q_expr

    traceTc (text "Got result" <+> ppr expr2)
350

351
    showSplice "expression" expr (ppr expr2)
352

353
354
        -- Rename it, but bale out if there are errors
        -- otherwise the type checker just gives more spurious errors
355
    (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
356

357
    tcMonoExpr exp3 res_ty
358
359


360
tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
361
362
-- Type check an expression that is the body of a top-level splice
--   (the caller will compile and run it)
363
364
365
366
367
368
369
370
tcTopSpliceExpr expr meta_ty 
  = checkNoErrs $  -- checkNoErrs: must not try to run the thing
                   -- if the type checker fails!
    do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
                                 (recordThUse >> tcMonoExpr expr meta_ty)
          -- Zonk it and tie the knot of dictionary bindings
       ; zonkTopLExpr (mkHsDictLet const_binds expr') }
\end{code}
371
372


373
374
375
376
377
%************************************************************************
%*									*
	Annotations
%*									*
%************************************************************************
378

379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
\begin{code}
runAnnotation target expr = do
    expr_ty <- newFlexiTyVarTy liftedTypeKind
    
    -- Find the classes we want instances for in order to call toAnnotationWrapper
    data_class <- tcLookupClass dataClassName
    
    -- Check the instances we require live in another module (we want to execute it..)
    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
    -- also resolves the LIE constraints to detect e.g. instance ambiguity
    ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
                expr' <- tcPolyExprNC expr expr_ty
                -- By instantiating the call >here< it gets registered in the 
		-- LIE consulted by tcSimplifyStagedExpr
                -- and hence ensures the appropriate dictionary is bound by const_binds
                wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
                return (wrapper, expr')

    -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
    loc <- getSrcSpanM
    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
    let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
        wrapped_expr' = mkHsDictLet const_binds $
                        L loc (HsApp specialised_to_annotation_wrapper_expr expr')

    -- If we have type checking problems then potentially zonking 
    -- (and certainly compilation) may fail. Give up NOW!
    failIfErrsM

    -- Zonk the type variables out of that raw expression. Note that
    -- in particular we don't call recordThUse, since we don't
    -- necessarily use any code or definitions from that package.
    zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'

    -- Run the appropriately wrapped expression to get the value of
    -- the annotation and its dictionaries. The return value is of
    -- type AnnotationWrapper by construction, so this conversion is
    -- safe
    flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
        case annotation_wrapper of
            AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
                -- Got the value and dictionaries: build the serialized value and 
		-- call it a day. We ensure that we seq the entire serialized value 
		-- in order that any errors in the user-written code for the
                -- annotation are exposed at this point.  This is also why we are 
		-- doing all this stuff inside the context of runMeta: it has the 
		-- facilities to deal with user error in a meta-level expression
                seqSerialized serialized `seq` Annotation { 
                    ann_target = target,
                    ann_value = serialized
                }
430
431
432
\end{code}


433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
%************************************************************************
%*									*
	Quasi-quoting
%*									*
%************************************************************************

Note [Quasi-quote overview]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The GHC "quasi-quote" extension is described by Geoff Mainland's paper
"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell
Workshop 2007).

Briefly, one writes
	[:p| stuff |]
and the arbitrary string "stuff" gets parsed by the parser 'p', whose
type should be Language.Haskell.TH.Quote.QuasiQuoter.  'p' must be
defined in another module, because we are going to run it here.  It's
a bit like a TH splice:
	$(p "stuff")

However, you can do this in patterns as well as terms.  Becuase of this,
the splice is run by the *renamer* rather than the type checker.

\begin{code}
runQuasiQuote :: Outputable hs_syn
              => HsQuasiQuote Name	-- Contains term of type QuasiQuoter, and the String
              -> Name			-- Of type QuasiQuoter -> String -> Q th_syn
              -> String			-- Documentation string only
              -> Name			-- Name of th_syn type  
              -> (SrcSpan -> th_syn -> Either Message hs_syn)
              -> TcM hs_syn
464
runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
  = do	{ -- Check that the quoter is not locally defined, otherwise the TH
          -- machinery will not be able to run the quasiquote.
        ; this_mod <- getModule
        ; let is_local = case nameModule_maybe quoter of
                           Just mod | mod == this_mod -> True
                                    | otherwise       -> False
                           Nothing -> True
	; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
        ; checkTc (not is_local) (quoteStageError quoter)

	  -- Build the expression 
      	; let quoterExpr = L q_span $! HsVar $! quoter
      	; let quoteExpr = L q_span $! HsLit $! HsString quote
      	; let expr = L q_span $
      	             HsApp (L q_span $
      	                    HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr
      	; recordThUse
      	; meta_exp_ty <- tcMetaTy meta_ty

      	-- Typecheck the expression
      	; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty

      	-- Run the expression
      	; traceTc (text "About to run" <+> ppr zonked_q_expr)
489
      	; result <- runMetaQ convert zonked_q_expr
490
      	; traceTc (text "Got result" <+> ppr result)
491
      	; showSplice desc quoteExpr (ppr result)
492
493
494
495
496
497
498
499
500
      	; return result
      	}

runQuasiQuoteExpr quasiquote
    = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr

runQuasiQuotePat quasiquote
    = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat

501
quoteStageError :: Name -> SDoc
502
quoteStageError quoter
Ian Lynagh's avatar
Ian Lynagh committed
503
504
  = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
         nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
505
506
507
\end{code}


508
509
510
511
512
513
514
515
516
517
%************************************************************************
%*									*
		Splicing a type
%*									*
%************************************************************************

Very like splicing an expression, but we don't yet share code.

\begin{code}
kcSpliceType (HsSplice name hs_expr)
518
  = setSrcSpan (getLoc hs_expr) $ do 	
519
520
521
522
523
524
	{ level <- getStage
	; case spliceOK level of {
		Nothing 	-> failWithTc (illegalSplice level) ;
		Just next_level -> do 

	{ case level of {
525
		Comp _ 		       -> do { (t,k) <- kcTopSpliceType hs_expr 
526
527
528
529
530
531
532
					     ; return (unLoc t, k) } ;
		Brack _ ps_var lie_var -> do

	{ 	-- A splice inside brackets
	; meta_ty <- tcMetaTy typeQTyConName
	; expr' <- setStage (Splice next_level) $
		   setLIEVar lie_var	   	$
533
		   tcMonoExpr hs_expr meta_ty
534
535
536
537
538
539
540
541
542

		-- Write the pending splice into the bucket
	; ps <- readMutVar ps_var
	; writeMutVar ps_var ((name,expr') : ps)

	-- e.g.   [| Int -> $(h 4) |]
	-- Here (h 4) :: Q Type
	-- but $(h 4) :: forall a.a 	i.e. any kind
	; kind <- newKindVar
543
	; return (panic "kcSpliceType", kind)	-- The returned type is ignored
544
545
546
    }
        ; Splice {} -> panic "kcSpliceType Splice"
    }}}}
547
548
549
550
551
552
553
554
555
556

kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
kcTopSpliceType expr
  = do	{ meta_ty <- tcMetaTy typeQTyConName

	-- Typecheck the expression
	; zonked_q_expr <- tcTopSpliceExpr expr meta_ty

	-- Run the expression
	; traceTc (text "About to run" <+> ppr zonked_q_expr)
557
	; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
558
559
560
  
	; traceTc (text "Got result" <+> ppr hs_ty2)

561
	; showSplice "type" expr (ppr hs_ty2)
562
563
564

	-- Rename it, but bale out if there are errors
	-- otherwise the type checker just gives more spurious errors
Ian Lynagh's avatar
Ian Lynagh committed
565
	; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
566
567
	; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)

568
	; kcLHsType hs_ty3 }
569
570
\end{code}

571
572
573
574
575
576
577
578
%************************************************************************
%*									*
\subsection{Splicing an expression}
%*									*
%************************************************************************

\begin{code}
-- Always at top level
579
580
-- Type sig at top of file:
-- 	tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
581
tcSpliceDecls expr
582
583
584
585
586
587
588
  = do	{ meta_dec_ty <- tcMetaTy decTyConName
	; meta_q_ty <- tcMetaTy qTyConName
	; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
	; zonked_q_expr <- tcTopSpliceExpr expr list_q

		-- Run the expression
	; traceTc (text "About to run" <+> ppr zonked_q_expr)
589
	; decls <- runMetaD convertToHsDecls zonked_q_expr
590
591
592

	; traceTc (text "Got result" <+> vcat (map ppr decls))
	; showSplice "declarations"
593
	  	     expr 
594
		     (ppr (getLoc expr) $$ (vcat (map ppr decls)))
595
	; return decls }
596
597
598
599
600
601
602
603
604
605
\end{code}


%************************************************************************
%*									*
\subsection{Running an expression}
%*									*
%************************************************************************

\begin{code}
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
runMetaAW :: (AnnotationWrapper -> output)
          -> LHsExpr Id         -- Of type AnnotationWrapper
          -> TcM output
runMetaAW k = runMeta False (\_ -> return . Right . k)
    -- We turn off showing the code in meta-level exceptions because doing so exposes
    -- the toAnnotationWrapper function that we slap around the users code

runQThen :: (SrcSpan -> input -> Either Message output)
         -> SrcSpan
         -> TH.Q input
         -> TcM (Either Message output)
runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)

runMetaQ :: (SrcSpan -> input -> Either Message output)
	 -> LHsExpr Id
	 -> TcM output
runMetaQ = runMeta True . runQThen

624
625
626
runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
	 -> LHsExpr Id 		-- Of type (Q Exp)
	 -> TcM (LHsExpr RdrName)
627
runMetaE = runMetaQ
628

629
630
631
runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
         -> LHsExpr Id          -- Of type (Q Pat)
         -> TcM (Pat RdrName)
632
runMetaP = runMetaQ
633

634
635
636
runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
	 -> LHsExpr Id 		-- Of type (Q Type)
	 -> TcM (LHsType RdrName)	
637
runMetaT = runMetaQ
638
639
640
641

runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
	 -> LHsExpr Id 		-- Of type Q [Dec]
	 -> TcM [LHsDecl RdrName]
642
runMetaD = runMetaQ
643

644
645
runMeta :: Bool                 -- Whether code should be printed in the exception message
        -> (SrcSpan -> input -> TcM (Either Message output))
646
	-> LHsExpr Id 		-- Of type X
647
648
	-> TcM output		-- Of type t
runMeta show_code run_and_convert expr
649
  = do	{ 	-- Desugar
650
	  ds_expr <- initDsTc (dsLExpr expr)
651
	-- Compile and link it; might fail if linking fails
652
653
	; hsc_env <- getTopEnv
	; src_span <- getSrcSpanM
twanvl's avatar
twanvl committed
654
	; either_hval <- tryM $ liftIO $
655
			 HscMain.compileExpr hsc_env src_span ds_expr
656
657
658
659
660
	; case either_hval of {
	    Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
	    Right hval -> do

	{ 	-- Coerce it to Q t, and run it
661

662
663
		-- Running might fail if it throws an exception of any kind (hence tryAllM)
		-- including, say, a pattern-match exception in the code we are running
664
665
666
667
		--
		-- We also do the TH -> HS syntax conversion inside the same
		-- exception-cacthing thing so that if there are any lurking 
		-- exceptions in the data structure returned by hval, we'll
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
668
		-- encounter them inside the try
669
670
		--
		-- See Note [Exceptions in TH] 
671
672
673
674
	  let expr_span = getLoc expr
	; either_tval <- tryAllM $
            		 setSrcSpan expr_span $	-- Set the span so that qLocation can
						-- see where this splice is
675
676
	     do	{ mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
		; case mb_result of
677
		    Left err     -> failWithTc err
678
		    Right result -> return $! result }
679
680
681

	; case either_tval of
	    Right v -> return v
682
683
	    Left se ->
                    case fromException se of
684
                    Just IOEnvFailure ->
685
                        failM -- Error already in Tc monad
686
                    _ -> failWithTc (mk_msg "run" se)	-- Exception
687
        }}}
688
689
690
  where
    mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
			 nest 2 (text (Panic.showException exn)),
691
			 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
692
693
\end{code}

694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
Note [Exceptions in TH]
~~~~~~~~~~~~~~~~~~~~~~~
Supppose we have something like this 
	$( f 4 )
where
	f :: Int -> Q [Dec]
	f n | n>3       = fail "Too many declarations"
	    | otherwise = ...

The 'fail' is a user-generated failure, and should be displayed as a
perfectly ordinary compiler error message, not a panic or anything
like that.  Here's how it's processed:

  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
    effectively transforms (fail s) to 
	qReport True s >> fail
    where 'qReport' comes from the Quasi class and fail from its monad
    superclass.

  * The TcM monad is an instance of Quasi (see TcSplice), and it implements
    (qReport True s) by using addErr to add an error message to the bag of errors.
715
    The 'fail' in TcM raises an IOEnvFailure exception
716
717

  * So, when running a splice, we catch all exceptions; then for 
718
	- an IOEnvFailure exception, we assume the error is already 
719
720
721
722
723
		in the error-bag (above)
	- other errors, we add an error to the bag
    and then fail


724
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
725

726
727
\begin{code}
instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
728
  qNewName s = do { u <- newUnique 
729
730
		  ; let i = getKey u
		  ; return (TH.mkNameU s i) }
731

732
733
  qReport True msg  = addErr (text msg)
  qReport False msg = addReport (text msg)
734

735
736
737
738
739
740
741
742
  qLocation = do { m <- getModule
		 ; l <- getSrcSpanM
		 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
				  , TH.loc_module   = moduleNameString (moduleName m)
				  , TH.loc_package  = packageIdString (modulePackageId m)
				  , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
				  , TH.loc_end = (srcSpanEndLine   l, srcSpanEndCol   l) }) }
		
743
  qReify v = reify v
744
745
746
747
748
749
750
751
752
753

	-- For qRecover, discard error messages if 
	-- the recovery action is chosen.  Otherwise
	-- we'll only fail higher up.  c.f. tryTcLIE_
  qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
			     ; case mb_res of
		  	         Just val -> do { addMessages msgs	-- There might be warnings
				   	        ; return val }
		  	         Nothing  -> recover			-- Discard all msgs
			  }
754

twanvl's avatar
twanvl committed
755
  qRunIO io = liftIO io
756
\end{code}
757
758
759
760
761
762
763
764
765


%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

\begin{code}
766
767
768
769
770
771
772
773
774
775
776
777
showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
-- Note that 'before' is *renamed* but not *typechecked*
-- Reason (a) less typechecking crap
--        (b) data constructors after type checking have been
--	      changed to their *wrappers*, and that makes them
--	      print always fully qualified
showSplice what before after
  = do { loc <- getSrcSpanM
       ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, 
		            nest 2 (sep [nest 2 (ppr before),
				         text "======>",
				         nest 2 after])]) }
778

779
illegalBracket :: ThStage -> SDoc
780
illegalBracket level
Ian Lynagh's avatar
Ian Lynagh committed
781
  = ptext (sLit "Illegal bracket at level") <+> ppr level
782

783
illegalSplice :: ThStage -> SDoc
784
illegalSplice level
Ian Lynagh's avatar
Ian Lynagh committed
785
  = ptext (sLit "Illegal splice at level") <+> ppr level
786
787
788

#endif 	/* GHCI */
\end{code}
789
790
791
792
793
794
795
796
797
798
799


%************************************************************************
%*									*
			Reification
%*									*
%************************************************************************


\begin{code}
reify :: TH.Name -> TcM TH.Info
800
801
reify th_name
  = do	{ name <- lookupThName th_name
802
	; thing <- tcLookupTh name
803
804
		-- ToDo: this tcLookup could fail, which would give a
		-- 	 rather unhelpful error message
805
	; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
806
807
	; reifyThing thing
    }
808
  where
Simon Marlow's avatar
Simon Marlow committed
809
810
811
    ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
    ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
812
    ppr_ns _ = panic "reify/ppr_ns"
813
814

lookupThName :: TH.Name -> TcM Name
815
816
817
818
819
820
821
822
823
824
825
lookupThName th_name = do
    mb_name <- lookupThName_maybe th_name
    case mb_name of
        Nothing   -> failWithTc (notInScope th_name)
        Just name -> return name

lookupThName_maybe th_name
  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
          -- Pick the first that works
	  -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
	; return (listToMaybe names) }	
826
  where
827
828
829
830
831
832
    lookup rdr_name
	= do { 	-- Repeat much of lookupOccRn, becase we want
		-- to report errors in a TH-relevant way
	     ; rdr_env <- getLocalRdrEnv
  	     ; case lookupLocalRdrEnv rdr_env rdr_name of
		 Just name -> return (Just name)
833
	         Nothing   -> lookupGlobalOccRn_maybe rdr_name }
834

835
836
837
838
839
840
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
-- it gives a reify-related error message on failure, whereas in the normal
-- tcLookup, failure is a bug.
tcLookupTh name
  = do	{ (gbl_env, lcl_env) <- getEnvs
841
	; case lookupNameEnv (tcl_env lcl_env) name of {
842
		Just thing -> return thing;
843
844
845
846
847
848
849
850
851
		Nothing    -> do
	{ if nameIsLocalOrFrom (tcg_mod gbl_env) name
	  then	-- It's defined in this module
	      case lookupNameEnv (tcg_type_env gbl_env) name of
		Just thing -> return (AGlobal thing)
		Nothing	   -> failWithTc (notInEnv name)
	 
	  else do 		-- It's imported
	{ (eps,hpt) <- getEpsAndHpt
Simon Marlow's avatar
Simon Marlow committed
852
853
        ; dflags <- getDOpts
	; case lookupType dflags hpt (eps_PTE eps) name of 
854
	    Just thing -> return (AGlobal thing)
855
	    Nothing    -> do { thing <- tcImportDecl name
856
857
858
			     ; return (AGlobal thing) }
		-- Imported names should always be findable; 
		-- if not, we fail hard in tcImportDecl
859
    }}}}
860

861
notInScope :: TH.Name -> SDoc
862
notInScope th_name = quotes (text (TH.pprint th_name)) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
863
		     ptext (sLit "is not in scope at a reify")
864
865
	-- Ugh! Rather an indirect way to display the name

866
867
notInEnv :: Name -> SDoc
notInEnv name = quotes (ppr name) <+> 
Ian Lynagh's avatar
Ian Lynagh committed
868
		     ptext (sLit "is not in the type environment at a reify")
869

870
871
872
873
874
875
876
877
878
879
------------------------------
reifyThing :: TcTyThing -> TcM TH.Info
-- The only reason this is monadic is for error reporting,
-- which in turn is mainly for the case when TH can't express
-- some random GHC extension

reifyThing (AGlobal (AnId id))
  = do	{ ty <- reifyType (idType id)
	; fix <- reifyFixity (idName id)
	; let v = reifyName id
880
	; case idDetails id of
881
	    ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
882
	    _                -> return (TH.VarI     v ty Nothing fix)
883
884
    }

885
886
reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
reifyThing (AGlobal (AClass cls)) = reifyClass cls
887
888
889
890
reifyThing (AGlobal (ADataCon dc))
  = do	{ let name = dataConName dc
	; ty <- reifyType (idType (dataConWrapId dc))
	; fix <- reifyFixity name
891
892
893
	; return (TH.DataConI (reifyName name) ty 
                              (reifyName (dataConOrigTyCon dc)) fix) 
        }
894

895
reifyThing (ATcId {tct_id = id, tct_type = ty}) 
896
897
  = do	{ ty1 <- zonkTcType ty	-- Make use of all the info we have, even
				-- though it may be incomplete
898
899
900
901
	; ty2 <- reifyType ty1
	; fix <- reifyFixity (idName id)
	; return (TH.VarI (reifyName id) ty2 Nothing fix) }

902
903
reifyThing (ATyVar tv ty) 
  = do	{ ty1 <- zonkTcType ty
904
905
906
	; ty2 <- reifyType ty1
	; return (TH.TyVarI (reifyName tv) ty2) }

907
908
reifyThing (AThing {}) = panic "reifyThing AThing"

909
------------------------------
910
reifyTyCon :: TyCon -> TcM TH.Info
911
reifyTyCon tc
912
913
914
915
916
917
918
  | isFunTyCon tc  
  = return (TH.PrimTyConI (reifyName tc) 2 		  False)
  | isPrimTyCon tc 
  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
  | isOpenTyCon tc
  = let flavour = reifyFamFlavour tc
        tvs     = tyConTyVars tc
919
920
921
922
        kind    = tyConKind tc
        kind'
          | isLiftedTypeKind kind = Nothing
          | otherwise             = Just $ reifyKind kind
923
924
    in
    return (TH.TyConI $
925
              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
926
  | isSynTyCon tc
927
928
929
  = do { let (tvs, rhs) = synTyConDefn tc 
       ; rhs' <- reifyType rhs
       ; return (TH.TyConI $ 
930
931
		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
       }
932

933
reifyTyCon tc
934
  = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
935
936
	; let tvs = tyConTyVars tc
	; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
937
	; let name = reifyName tc
938
	      r_tvs  = reifyTyVars tvs
939
	      deriv = []	-- Don't know about deriving
940
	      decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
941
		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	    deriv
942
	; return (TH.TyConI decl) }
943

944
945
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
reifyDataCon tys dc
946
  | isVanillaDataCon dc
947
  = do 	{ arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
948
949
	; let stricts = map reifyStrict (dataConStrictMarks dc)
	      fields  = dataConFieldLabels dc
950
951
952
953
954
955
	      name    = reifyName dc
	      [a1,a2] = arg_tys
	      [s1,s2] = stricts
	; ASSERT( length arg_tys == length stricts )
          if not (null fields) then
	     return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
956
	  else
957
958
	  if dataConIsInfix dc then
	     ASSERT( length arg_tys == 2 )
959
	     return (TH.InfixC (s1,a1) name (s2,a2))
960
961
	  else
	     return (TH.NormalC name (stricts `zip` arg_tys)) }
962
  | otherwise
963
  = failWithTc (ptext (sLit "Can't reify a GADT data constructor:") 
964
		<+> quotes (ppr dc))
965
966

------------------------------
967
reifyClass :: Class -> TcM TH.Info
968
969
970
reifyClass cls 
  = do	{ cxt <- reifyCxt theta
	; ops <- mapM reify_op op_stuff
971
	; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
972
  where
973
    (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
974
    fds' = map reifyFunDep fds
975
976
977
978
979
980
981
982
983
984
985
986
987
988
    reify_op (op, _) = do { ty <- reifyType (idType op)
			  ; return (TH.SigD (reifyName op) ty) }

------------------------------
reifyType :: TypeRep.Type -> TcM TH.Type
reifyType (TyVarTy tv)	    = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType (FunTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; 
				 ; tau' <- reifyType tau 
				 ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
			    where
				(tvs, cxt, tau) = tcSplitSigmaTy ty
989
990
991
reifyType (PredTy {}) = panic "reifyType PredTy"

reifyTypes :: [Type] -> TcM [TH.Type]
992
reifyTypes = mapM reifyType
993

994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
reifyKind :: Kind -> TH.Kind
reifyKind  ki
  = let (kis, ki') = splitKindFunTys ki
        kis_rep    = map reifyKind kis
        ki'_rep    = reifyNonArrowKind ki'
    in
    foldl TH.ArrowK ki'_rep kis_rep
  where
    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
                        | otherwise          = pprPanic "Exotic form of kind" 
                                                        (ppr k)

1006
reifyCxt :: [PredType] -> TcM [TH.Pred]
1007
1008
reifyCxt   = mapM reifyPred

1009
1010
1011
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)

1012
1013
1014
1015
1016
1017
reifyFamFlavour :: TyCon -> TH.FamFlavour
reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
                   | isOpenTyCon    tc = TH.DataFam
                   | otherwise         
                   = panic "TcSplice.reifyFamFlavour: not a type family"

1018
1019
1020
1021
1022
1023
1024
1025
reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
reifyTyVars = map reifyTyVar
  where
    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
                  | otherwise             = TH.KindedTV name (reifyKind kind)
      where
        kind = tyVarKind tv
        name = reifyName tv
1026
1027
1028
1029
1030

reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
reify_tc_app tc tys = do { tys' <- reifyTypes tys 
			 ; return (foldl TH.AppT (TH.ConT tc) tys') }

1031
1032
1033
1034
1035
reifyPred :: TypeRep.PredType -> TcM TH.Pred
reifyPred (ClassP cls tys) 
  = do { tys' <- reifyTypes tys 
       ; return $ TH.ClassP (reifyName cls) tys'
       }
Ian Lynagh's avatar
Ian Lynagh committed
1036
reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
1037
1038
1039
1040
1041
reifyPred (EqPred ty1 ty2) 
  = do { ty1' <- reifyType ty1
       ; ty2' <- reifyType ty2
       ; return $ TH.EqualP ty1' ty2'
       }
1042
1043
1044
1045
1046


------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
Simon Marlow's avatar
Simon Marlow committed
1047
  | isExternalName name = mk_varg pkg_str mod_str occ_str
1048
  | otherwise	        = TH.mkNameU occ_str (getKey (getUnique name))
1049
1050
1051
1052
	-- Many of the things we reify have local bindings, and 
	-- NameL's aren't supposed to appear in binding positions, so
	-- we use NameU.  When/if we start to reify nested things, that
	-- have free variables, we may need to generate NameL's for them.
1053
1054
  where
    name    = getName thing
1055
    mod     = ASSERT( isExternalName name ) nameModule name
Simon Marlow's avatar
Simon Marlow committed
1056
1057
    pkg_str = packageIdString (modulePackageId mod)
    mod_str = moduleNameString (moduleName mod)
1058
    occ_str = occNameString occ
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
    occ     = nameOccName name
    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
	    | OccName.isVarOcc  occ = TH.mkNameG_v
	    | OccName.isTcOcc   occ = TH.mkNameG_tc
	    | otherwise		    = pprPanic "reifyName" (ppr name)

------------------------------
reifyFixity :: Name -> TcM TH.Fixity
reifyFixity name
  = do	{ fix <- lookupFixityRn name
	; return (conv_fix fix) }
    where
      conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d)
      conv_dir BasicTypes.InfixR = TH.InfixR
      conv_dir BasicTypes.InfixL = TH.InfixL
      conv_dir BasicTypes.InfixN = TH.InfixN

reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
reifyStrict MarkedStrict    = TH.IsStrict
reifyStrict MarkedUnboxed   = TH.IsStrict
reifyStrict NotMarkedStrict = TH.NotStrict

------------------------------
noTH :: LitString -> SDoc -> TcM a
Ian Lynagh's avatar
Ian Lynagh committed
1083
1084
noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> 
				ptext (sLit "in Template Haskell:"),
1085
		 	     nest 2 d])
1086
\end{code}