TcSplice.lhs 39.1 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
                 lookupThName_maybe,
18
todoSession, todoTcM,
19
                 runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
20
21
22

#include "HsVersions.h"

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

28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
46
import PrelNames
47
import HscTypes
48
import OccName
49
50
import Var
import Module
51
import Annotations
52
import TcRnMonad
53
import Class
54
import Inst
55
56
57
58
59
60
61
62
import TyCon
import DataCon
import Id
import IdInfo
import TysWiredIn
import DsMeta
import DsExpr
import DsMonad hiding (Splice)
63
import Serialized
64
65
import ErrUtils
import SrcLoc
66
import Outputable
67
import Unique
Ian Lynagh's avatar
Ian Lynagh committed
68
import Data.Maybe
69
70
71
import BasicTypes
import Panic
import FastString
72
import Exception
73

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

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

83
import GHC.Exts		( unsafeCoerce#, Int#, Int(..) )
84
import System.IO.Error
85
86
87
88
89
90
91
92
93
94
95
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


--here for every bad reason :-)
import InstEnv
import FamInstEnv
--Session
todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
todoSession hsc_env name
  = initTcPrintErrors hsc_env iNTERACTIVE $ 
    setInteractiveContext hsc_env (hsc_IC hsc_env) $
    todoTcM name


todoTcM :: Name -> TcM (LHsDecl RdrName)
todoTcM name = do
  tcTyThing <- TcEnv.tcLookup name
  thInfo <- TcSplice.reifyThing tcTyThing
  let Just thDec = thGetDecFromInfo thInfo --BUG!
  let Right [hsdecl] = Convert.convertToHsDecls
        (error "srcspan of different package?")
        [thDec]
  return hsdecl

thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
thGetDecFromInfo (TH.ClassI dec) = Just dec
thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
thGetDecFromInfo (TH.TyConI dec) = Just dec
thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
thGetDecFromInfo (TH.DataConI {}) = error "datacon"
thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...

setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside 
  = let -- Initialise the tcg_inst_env with instances from all home modules.  
        -- This mimics the more selective call to hptInstances in tcRnModule.
Simon Marlow's avatar
Simon Marlow committed
122
	(home_insts, home_fam_insts) = hptInstances hsc_env (\_mod -> True)
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
    in
    updGblEnv (\env -> env { 
	tcg_rdr_env      = ic_rn_gbl_env icxt,
	tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
	tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
                                                home_fam_insts 
      }) $

    tcExtendGhciEnv (ic_tmp_ids icxt) $
        -- tcExtendGhciEnv does lots: 
        --   - it extends the local type env (tcl_env) with the given Ids,
        --   - it extends the local rdr env (tcl_rdr) with the Names from 
        --     the given Ids
        --   - it adds the free tyvars of the Ids to the tcl_tyvars
        --     set.
        --
        -- later ids in ic_tmp_ids must shadow earlier ones with the same
        -- OccName, and tcExtendIdEnv implements this behaviour.

    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
 	; thing_inside }
144
145
\end{code}

146
147
148
Note [Template Haskell levels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* Imported things are impLevel (= 0)
149
150
151
152

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

153
* Variables are bound at the "current level"
154

155
* The current level starts off at topLevel (= 1)
156

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
* 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 |]

182
183
See Note [What is a top-level Id?]

184
185
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
186
187
188
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:
189

190
191
192
193
194
195
196
197
	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:
198
199
200
201
202
203
204
205
206
207
208

  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


209
210
211
212
213
214
215
216
217
218
219
220
221
222
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.

223
224
225
226
227
228
229
230

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

\begin{code}
231
tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
232
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
233
tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
234
kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
235
	-- None of these functions add constraints to the LIE
236

237
238
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)

239
240
runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
runQuasiQuotePat  :: HsQuasiQuote Name -> TcM (LPat RdrName)
241
runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
242

243
#ifndef GHCI
244
245
246
247
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)
248

249
250
lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)

251
252
runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
runQuasiQuotePat  q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
253
runAnnotation   _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
254
255
256
257
258
#else
\end{code}

%************************************************************************
%*									*
259
\subsection{Quoting an expression}
260
261
262
%*									*
%************************************************************************

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
263
264
265
266
267
268
269
270
271
272
273
274
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) }

275
\begin{code}
276
277
278
279
280
281
282
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 {
283
284
285
286

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

291
292
293
       ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
                                    (getLIE (tc_bracket next_level brack))
       ; tcSimplifyBracket lie
294

295
	-- Make the expected type have the right shape
296
       ; _ <- boxyUnify meta_ty res_ty
297
298

	-- Return the original expression, not the type-decorated one
299
300
       ; pendings <- readMutVar pending_splices
       ; return (noLoc (HsBracketOut brack pendings)) }}}
301

302
303
tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
tc_bracket use_lvl (VarBr name) 	-- Note [Quoting names]
304
305
306
  = do	{ thing <- tcLookup name
	; case thing of
    	    AGlobal _ -> return ()
307
308
309
    	    ATcId { tct_level = bind_lvl, tct_id = id }
		| thTopLevelId id	-- C.f thTopLevelId case of
		-> keepAliveTc id 	--     TcExpr.thBrackId
310
		| otherwise
311
		-> do { checkTc (use_lvl == bind_lvl)
312
				(quotedNameStageErr name) }
313
	    _ -> pprPanic "th_bracket" (ppr name)
314
315
316

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

318
tc_bracket _ (ExpBr expr) 
319
  = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
320
	; _ <- tcMonoExprNC expr any_ty  -- NC for no context; tcBracket does that
321
	; tcMetaTy expQTyConName }
322
	-- Result type is Expr (= Q Exp)
323

324
tc_bracket _ (TypBr typ) 
325
  = do	{ _ <- tcHsSigTypeNC ThBrackCtxt typ
326
	; tcMetaTy typeQTyConName }
327
328
	-- Result type is Type (= Q Typ)

329
tc_bracket _ (DecBr decls)
330
  = do	{ _ <- tcTopSrcDecls emptyModDetails decls
331
332
333
	-- Typecheck the declarations, dicarding the result
	-- We'll get all that stuff later, when we splice it in

334
335
336
	; decl_ty <- tcMetaTy decTyConName
	; q_ty    <- tcMetaTy qTyConName
	; return (mkAppTy q_ty (mkListTy decl_ty))
337
	-- Result type is Q [Dec]
338
    }
339

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

343
quotedNameStageErr :: Name -> SDoc
344
quotedNameStageErr v 
Ian Lynagh's avatar
Ian Lynagh committed
345
346
  = 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")]
347
348
\end{code}

349

350
351
352
353
354
355
%************************************************************************
%*									*
\subsection{Splicing an expression}
%*									*
%************************************************************************

356
\begin{code}
357
tcSpliceExpr (HsSplice name expr) res_ty
358
359
  = setSrcSpan (getLoc expr) 	$ do
    level <- getStage
360
361
362
363
    case spliceOK level of {
	Nothing 	-> failWithTc (illegalSplice level) ;
	Just next_level -> 

364
     case level of {
365
	Comp _ 		       -> do { e <- tcTopSplice expr res_ty
366
367
				     ; return (unLoc e) } ;
	Brack _ ps_var lie_var -> do
368
369

	-- A splice inside brackets
370
  	-- NB: ignore res_ty, apart from zapping it to a mono-type
371
372
373
374
	-- e.g.   [| reverse $(h 4) |]
	-- Here (h 4) :: Q Exp
	-- but $(h 4) :: forall a.a 	i.e. anything!

375
      _ <- unBox res_ty
376
377
378
379
380
      meta_exp_ty <- tcMetaTy expQTyConName
      expr' <- setStage (Splice next_level) (
                 setLIEVar lie_var    $
                 tcMonoExpr expr meta_exp_ty
               )
381
382

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

386
      return (panic "tcSpliceExpr")	-- The returned expression is ignored
387
388

     ; Splice {} -> panic "tcSpliceExpr Splice"
389
     }} 
390
391
392
393
394

-- 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) ... )
395
-- The recursive call to tcMonoExpr will simply expand the 
396
397
-- inner escape before dealing with the outer one

398
tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr Id)
399
400
tcTopSplice expr res_ty = do
    meta_exp_ty <- tcMetaTy expQTyConName
401

402
403
        -- Typecheck the expression
    zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty
404

405
406
407
408
409
        -- Run the expression
    traceTc (text "About to run" <+> ppr zonked_q_expr)
    expr2 <- runMetaE convertToHsExpr zonked_q_expr

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

411
    showSplice "expression" expr (ppr expr2)
412

413
414
        -- Rename it, but bale out if there are errors
        -- otherwise the type checker just gives more spurious errors
415
    (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
416

417
    tcMonoExpr exp3 res_ty
418
419


420
tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
421
422
-- Type check an expression that is the body of a top-level splice
--   (the caller will compile and run it)
423
424
425
426
427
428
429
430
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}
431
432


433
434
435
436
437
%************************************************************************
%*									*
	Annotations
%*									*
%************************************************************************
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
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
\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
                }
490
491
492
\end{code}


493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
%************************************************************************
%*									*
	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
524
runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
  = 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)
549
      	; result <- runMetaQ convert zonked_q_expr
550
      	; traceTc (text "Got result" <+> ppr result)
551
      	; showSplice desc quoteExpr (ppr result)
552
553
554
555
556
557
558
559
560
      	; return result
      	}

runQuasiQuoteExpr quasiquote
    = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr

runQuasiQuotePat quasiquote
    = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat

561
quoteStageError :: Name -> SDoc
562
quoteStageError quoter
Ian Lynagh's avatar
Ian Lynagh committed
563
564
  = sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
         nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
565
566
567
\end{code}


568
569
570
571
572
573
574
575
576
577
%************************************************************************
%*									*
		Splicing a type
%*									*
%************************************************************************

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

\begin{code}
kcSpliceType (HsSplice name hs_expr)
578
  = setSrcSpan (getLoc hs_expr) $ do 	
579
580
581
582
583
584
	{ level <- getStage
	; case spliceOK level of {
		Nothing 	-> failWithTc (illegalSplice level) ;
		Just next_level -> do 

	{ case level of {
585
		Comp _ 		       -> do { (t,k) <- kcTopSpliceType hs_expr 
586
587
588
589
590
591
592
					     ; 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	   	$
593
		   tcMonoExpr hs_expr meta_ty
594
595
596
597
598
599
600
601
602

		-- 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
603
	; return (panic "kcSpliceType", kind)	-- The returned type is ignored
604
605
606
    }
        ; Splice {} -> panic "kcSpliceType Splice"
    }}}}
607
608
609
610
611
612
613
614
615
616

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)
617
	; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
618
619
620
  
	; traceTc (text "Got result" <+> ppr hs_ty2)

621
	; showSplice "type" expr (ppr hs_ty2)
622
623
624

	-- 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
625
	; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
626
627
	; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)

628
	; kcLHsType hs_ty3 }
629
630
\end{code}

631
632
633
634
635
636
637
638
%************************************************************************
%*									*
\subsection{Splicing an expression}
%*									*
%************************************************************************

\begin{code}
-- Always at top level
639
640
-- Type sig at top of file:
-- 	tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
641
tcSpliceDecls expr
642
643
644
645
646
647
648
  = 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)
649
	; decls <- runMetaD convertToHsDecls zonked_q_expr
650
651
652

	; traceTc (text "Got result" <+> vcat (map ppr decls))
	; showSplice "declarations"
653
	  	     expr 
654
		     (ppr (getLoc expr) $$ (vcat (map ppr decls)))
655
	; return decls }
656
657
658
659
660
661
662
663
664
665
\end{code}


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

\begin{code}
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
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

684
685
686
runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
	 -> LHsExpr Id 		-- Of type (Q Exp)
	 -> TcM (LHsExpr RdrName)
687
runMetaE = runMetaQ
688

689
690
691
runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
         -> LHsExpr Id          -- Of type (Q Pat)
         -> TcM (Pat RdrName)
692
runMetaP = runMetaQ
693

694
695
696
runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
	 -> LHsExpr Id 		-- Of type (Q Type)
	 -> TcM (LHsType RdrName)	
697
runMetaT = runMetaQ
698
699
700
701

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

704
705
runMeta :: Bool                 -- Whether code should be printed in the exception message
        -> (SrcSpan -> input -> TcM (Either Message output))
706
	-> LHsExpr Id 		-- Of type X
707
708
	-> TcM output		-- Of type t
runMeta show_code run_and_convert expr
709
  = do	{ 	-- Desugar
710
	  ds_expr <- initDsTc (dsLExpr expr)
711
	-- Compile and link it; might fail if linking fails
712
713
	; hsc_env <- getTopEnv
	; src_span <- getSrcSpanM
twanvl's avatar
twanvl committed
714
	; either_hval <- tryM $ liftIO $
715
			 HscMain.compileExpr hsc_env src_span ds_expr
716
717
718
719
720
	; case either_hval of {
	    Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
	    Right hval -> do

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

722
723
		-- 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
724
725
726
727
		--
		-- 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
728
		-- encounter them inside the try
729
730
		--
		-- See Note [Exceptions in TH] 
731
732
733
734
	  let expr_span = getLoc expr
	; either_tval <- tryAllM $
            		 setSrcSpan expr_span $	-- Set the span so that qLocation can
						-- see where this splice is
735
736
	     do	{ mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
		; case mb_result of
737
		    Left err     -> failWithTc err
738
		    Right result -> return $! result }
739
740
741

	; case either_tval of
	    Right v -> return v
742
743
	    Left se ->
                    case fromException se of
744
                    Just IOEnvFailure ->
745
                        failM -- Error already in Tc monad
746
                    _ -> failWithTc (mk_msg "run" se)	-- Exception
747
        }}}
748
749
750
  where
    mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
			 nest 2 (text (Panic.showException exn)),
751
			 if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
752
753
\end{code}

754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
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.
775
    The 'fail' in TcM raises an IOEnvFailure exception
776
777

  * So, when running a splice, we catch all exceptions; then for 
778
	- an IOEnvFailure exception, we assume the error is already 
779
780
781
782
783
		in the error-bag (above)
	- other errors, we add an error to the bag
    and then fail


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

786
787
\begin{code}
instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
788
  qNewName s = do { u <- newUnique 
789
790
		  ; let i = getKey u
		  ; return (TH.mkNameU s i) }
791

792
793
  qReport True msg  = addErr (text msg)
  qReport False msg = addReport (text msg)
794

795
796
797
798
799
800
801
802
  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) }) }
		
803
  qReify v = reify v
804
805
806
807
808
809
810
811
812
813

	-- 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
			  }
814

twanvl's avatar
twanvl committed
815
  qRunIO io = liftIO io
816
\end{code}
817
818
819
820
821
822
823
824
825


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

\begin{code}
826
827
828
829
830
831
832
833
834
835
836
837
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])]) }
838

839
illegalBracket :: ThStage -> SDoc
840
illegalBracket level
Ian Lynagh's avatar
Ian Lynagh committed
841
  = ptext (sLit "Illegal bracket at level") <+> ppr level
842

843
illegalSplice :: ThStage -> SDoc
844
illegalSplice level
Ian Lynagh's avatar
Ian Lynagh committed
845
  = ptext (sLit "Illegal splice at level") <+> ppr level
846
847
848

#endif 	/* GHCI */
\end{code}
849
850
851
852
853
854
855
856
857
858
859


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


\begin{code}
reify :: TH.Name -> TcM TH.Info
860
861
reify th_name
  = do	{ name <- lookupThName th_name
862
	; thing <- tcLookupTh name
863
864
		-- ToDo: this tcLookup could fail, which would give a
		-- 	 rather unhelpful error message
865
	; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
866
867
	; reifyThing thing
    }
868
  where
Simon Marlow's avatar
Simon Marlow committed
869
870
871
    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"
872
    ppr_ns _ = panic "reify/ppr_ns"
873
874

lookupThName :: TH.Name -> TcM Name
875
876
877
878
879
880
881
882
883
884
885
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) }	
886
  where
887
888
889
890
891
892
    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)
893
	         Nothing   -> lookupGlobalOccRn_maybe rdr_name }
894

895
896
897
898
899
900
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
901
	; case lookupNameEnv (tcl_env lcl_env) name of {
902
		Just thing -> return thing;
903
904
905
906
907
908
909
910
911
		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
912
913
        ; dflags <- getDOpts
	; case lookupType dflags hpt (eps_PTE eps) name of 
914
	    Just thing -> return (AGlobal thing)
915
	    Nothing    -> do { thing <- tcImportDecl name
916
917
918
			     ; return (AGlobal thing) }
		-- Imported names should always be findable; 
		-- if not, we fail hard in tcImportDecl
919
    }}}}
920

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

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

930
931
932
933
934
935
936
937
938
939
------------------------------
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
940
	; case idDetails id of
941
	    ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
942
	    _                -> return (TH.VarI     v ty Nothing fix)
943
944
    }

945
946
reifyThing (AGlobal (ATyCon tc))  = reifyTyCon tc
reifyThing (AGlobal (AClass cls)) = reifyClass cls
947
948
949
950
reifyThing (AGlobal (ADataCon dc))
  = do	{ let name = dataConName dc
	; ty <- reifyType (idType (dataConWrapId dc))
	; fix <- reifyFixity name
951
952
953
	; return (TH.DataConI (reifyName name) ty 
                              (reifyName (dataConOrigTyCon dc)) fix) 
        }
954

955
reifyThing (ATcId {tct_id = id, tct_type = ty}) 
956
957
  = do	{ ty1 <- zonkTcType ty	-- Make use of all the info we have, even
				-- though it may be incomplete
958
959
960
961
	; ty2 <- reifyType ty1
	; fix <- reifyFixity (idName id)
	; return (TH.VarI (reifyName id) ty2 Nothing fix) }

962
963
reifyThing (ATyVar tv ty) 
  = do	{ ty1 <- zonkTcType ty
964
965
966
	; ty2 <- reifyType ty1
	; return (TH.TyVarI (reifyName tv) ty2) }

967
968
reifyThing (AThing {}) = panic "reifyThing AThing"

969
------------------------------
970
reifyTyCon :: TyCon -> TcM TH.Info
971
reifyTyCon tc
972
973
974
975
976
977
978
  | 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
979
980
981
982
        kind    = tyConKind tc
        kind'
          | isLiftedTypeKind kind = Nothing
          | otherwise             = Just $ reifyKind kind
983
984
    in
    return (TH.TyConI $
985
              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
986
  | isSynTyCon tc
987
988
989
  = do { let (tvs, rhs) = synTyConDefn tc 
       ; rhs' <- reifyType rhs
       ; return (TH.TyConI $ 
990
991
		   TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') 
       }
992

993
reifyTyCon tc
994
  = do 	{ cxt <- reifyCxt (tyConStupidTheta tc)
995
996
	; let tvs = tyConTyVars tc
	; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
997
	; let name = reifyName tc
998
	      r_tvs  = reifyTyVars tvs
999
	      deriv = []	-- Don't know about deriving
1000
	      decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
1001
		   | otherwise	   = TH.DataD    cxt name r_tvs cons 	    deriv
1002
	; return (TH.TyConI decl) }
1003

1004
1005
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
reifyDataCon tys dc
1006
  | isVanillaDataCon dc
1007
  = do 	{ arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
1008
1009
	; let stricts = map reifyStrict (dataConStrictMarks dc)
	      fields  = dataConFieldLabels dc
1010
1011
1012
1013
1014
1015
	      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))
1016
	  else
1017
1018
	  if dataConIsInfix dc then
	     ASSERT( length arg_tys == 2 )
1019
	     return (TH.InfixC (s1,a1) name (s2,a2))
1020
1021
	  else
	     return (TH.NormalC name (stricts `zip` arg_tys)) }
1022
  | otherwise
1023
  = failWithTc (ptext (sLit "Can't reify a GADT data constructor:") 
1024
		<+> quotes (ppr dc))
1025
1026

------------------------------
1027
reifyClass :: Class -> TcM TH.Info
1028
1029
1030
reifyClass cls 
  = do	{ cxt <- reifyCxt theta
	; ops <- mapM reify_op op_stuff
1031
	; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
1032
  where
1033
    (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
1034
    fds' = map reifyFunDep fds
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
    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
1049
1050
1051
reifyType (PredTy {}) = panic "reifyType PredTy"

reifyTypes :: [Type] -> TcM [TH.Type]
1052
reifyTypes = mapM reifyType
1053

1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
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)

1066
reifyCxt :: [PredType] -> TcM [TH.Pred]
1067
1068
reifyCxt   = mapM reifyPred

1069
1070
1071
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)

1072
1073
1074
1075
1076
1077
reifyFamFlavour :: TyCon -> TH.FamFlavour
reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
                   | isOpenTyCon    tc = TH.DataFam
                   | otherwise         
                   = panic "TcSplice.reifyFamFlavour: not a type family"

1078
1079
1080
1081
1082
1083
1084
1085
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
1086
1087
1088
1089
1090

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') }

1091
1092
1093
1094
1095
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
1096
reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
1097
1098
1099
1100
1101
reifyPred (EqPred ty1 ty2) 
  = do { ty1' <- reifyType ty1
       ; ty2' <- reifyType ty2
       ; return $ TH.EqualP ty1' ty2'
       }
1102
1103
1104
1105
1106


------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
Simon Marlow's avatar
Simon Marlow committed
1107
  | isExternalName name = mk_varg pkg_str mod_str occ_str
1108
  | otherwise	        = TH.mkNameU occ_str (getKey (getUnique name))
1109
1110
1111
1112
	-- 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.
1113
1114
  where
    name    = getName thing
1115
    mod     = ASSERT( isExternalName name ) nameModule name
Simon Marlow's avatar
Simon Marlow committed
1116
1117
    pkg_str = packageIdString (modulePackageId mod)
    mod_str = moduleNameString (moduleName mod)
1118
    occ_str = occNameString occ
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
    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
1143
1144
noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> 
				ptext (sLit "in Template Haskell:"),
1145
		 	     nest 2 d])
1146
\end{code}