summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2011-11-05 18:19:33 +0000
committerIan Lynagh <igloo@earth.li>2011-11-05 18:19:33 +0000
commitbe6c2775d00748f93c38edf4989c6b69946786cf (patch)
tree6306be725f9791a4717d160795f11c65af9792fa
parent0dafee235fba5ce0852366e47476967b693f7795 (diff)
downloadhaskell-be6c2775d00748f93c38edf4989c6b69946786cf.tar.gz
Whitespace only in typecheck/TcSplice.lhs
-rw-r--r--compiler/typecheck/TcSplice.lhs973
1 files changed, 483 insertions, 490 deletions
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 8931378f23..401a1351a1 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -7,13 +7,6 @@ TcSplice: Template Haskell splices
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
@@ -23,7 +16,7 @@ TcSplice: Template Haskell splices
module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
- runQuasiQuoteExpr, runQuasiQuotePat,
+ runQuasiQuoteExpr, runQuasiQuotePat,
runQuasiQuoteDecl, runQuasiQuoteType,
runAnnotation ) where
@@ -31,8 +24,8 @@ module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
import HscMain
import TcRnDriver
- -- These imports are the reason that TcSplice
- -- is very high up the module hierarchy
+ -- These imports are the reason that TcSplice
+ -- is very high up the module hierarchy
import HsSyn
import Convert
@@ -54,7 +47,7 @@ import TcIface
import TypeRep
import FamInst
import FamInstEnv
-import InstEnv
+import InstEnv
import Name
import NameEnv
import NameSet
@@ -79,8 +72,8 @@ import Serialized
import ErrUtils
import SrcLoc
import Outputable
-import Util ( dropList )
-import Data.List ( mapAccumL )
+import Util ( dropList )
+import Data.List ( mapAccumL )
import Pair
import Unique
import Data.Maybe
@@ -88,7 +81,7 @@ import BasicTypes
import Panic
import FastString
import Exception
-import Control.Monad ( when )
+import Control.Monad ( when )
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
@@ -99,7 +92,7 @@ import qualified Language.Haskell.TH.Syntax as TH
import GHC.Desugar ( AnnotationWrapper(..) )
#endif
-import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
+import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import System.IO.Error
\end{code}
@@ -118,13 +111,13 @@ very straightforwardly:
e.g for HsType, rename and kind-check
for HsExpr, rename and type-check
- (The last step is different for decls, becuase they can *only* be
+ (The last step is different for decls, becuase they can *only* be
top-level: we return the result of step 2.)
Note [How brackets and nested splices are handled]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nested splices (those inside a [| .. |] quotation bracket), are treated
-quite differently.
+quite differently.
* After typechecking, the bracket [| |] carries
@@ -133,16 +126,16 @@ quite differently.
b) The quoted expression e, *renamed*: (HsExpr Name)
The expression e has been typechecked, but the result of
- that typechecking is discarded.
+ that typechecking is discarded.
- * The brakcet is desugared by DsMeta.dsBracket. It
+ * The brakcet is desugared by DsMeta.dsBracket. It
a) Extends the ds_meta environment with the PendingSplices
attached to the bracket
b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
run, will produce a suitable TH expression/type/decl. This
- is why we leave the *renamed* expression attached to the bracket:
+ is why we leave the *renamed* expression attached to the bracket:
the quoted expression should not be decorated with all the goop
added by the type checker
@@ -150,66 +143,66 @@ quite differently.
${n}(e). The name is initialised to an (Unqual "splice") when the
splice is created; the renamer gives it a unique.
- * When the type checker type-checks a nested splice ${n}(e), it
- - typechecks e
- - adds the typechecked expression (of type (HsExpr Id))
- as a pending splice to the enclosing bracket
- - returns something non-committal
- Eg for [| f ${n}(g x) |], the typechecker
- - attaches the typechecked term (g x) to the pending splices for n
- in the outer bracket
+ * When the type checker type-checks a nested splice ${n}(e), it
+ - typechecks e
+ - adds the typechecked expression (of type (HsExpr Id))
+ as a pending splice to the enclosing bracket
+ - returns something non-committal
+ Eg for [| f ${n}(g x) |], the typechecker
+ - attaches the typechecked term (g x) to the pending splices for n
+ in the outer bracket
- returns a non-committal type \alpha.
- Remember that the bracket discards the typechecked term altogether
+ Remember that the bracket discards the typechecked term altogether
* When DsMeta (used to desugar the body of the bracket) comes across
a splice, it looks up the splice's Name, n, in the ds_meta envt,
to find an (HsExpr Id) that should be substituted for the splice;
it just desugars it to get a CoreExpr (DsMeta.repSplice).
-Example:
- Source: f = [| Just $(g 3) |]
+Example:
+ 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
+ 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) }
+ Desugared: f = do { s7 <- g Int 3
+ ; return (ConE "Data.Maybe.Just" s7) }
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here are the ThStages, s, their corresponding level numbers
-(the result of (thLevel s)), and their state transitions.
+(the result of (thLevel s)), and their state transitions.
- ----------- $ ------------ $
+ ----------- $ ------------ $
| Comp | ---------> | Splice | -----|
- | 1 | | 0 | <----|
- ----------- ------------
- ^ | ^ |
- $ | | [||] $ | | [||]
- | v | v
- -------------- ----------------
- | Brack Comp | | Brack Splice |
- | 2 | | 1 |
- -------------- ----------------
-
-* Normal top-level declarations start in state Comp
+ | 1 | | 0 | <----|
+ ----------- ------------
+ ^ | ^ |
+ $ | | [||] $ | | [||]
+ | v | v
+ -------------- ----------------
+ | Brack Comp | | Brack Splice |
+ | 2 | | 1 |
+ -------------- ----------------
+
+* Normal top-level declarations start in state Comp
(which has level 1).
Annotations start in state Splice, since they are
treated very like a splice (only without a '$')
-* Code compiled in state Splice (and only such code)
+* Code compiled in state Splice (and only such code)
will be *run at compile time*, with the result replacing
the splice
* The original paper used level -1 instead of 0, etc.
-* The original paper did not allow a splice within a
- splice, but there is no reason not to. This is the
+* The original paper did not allow a splice within a
+ splice, but there is no reason not to. This is the
$ transition in the top right.
Note [Template Haskell levels]
@@ -224,76 +217,76 @@ Note [Template Haskell levels]
* The current level starts off at outerLevel (= 1)
* The level is decremented by splicing $(..)
- incremented by brackets [| |]
- incremented by name-quoting 'f
+ 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
+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 Always error (bound later than used)
+ [| \x -> $(f x) |]
- bind < use Inside brackets, it depends
- Inside splice, OK
- Inside neither, OK
+ 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 |]
+ - 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 |]
See Note [What is a top-level Id?]
Note [Quoting names]
~~~~~~~~~~~~~~~~~~~~
-A quoted name 'n is a bit like a quoted expression [| n |], except that we
+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:
- bind > use Error
- bind = use OK
- bind < use
- Imported things OK
- Top-level things OK
- Non-top-level Error
+ 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:
- f 'map -- OK; also for top-level defns of this module
+ 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
+ \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)
+ \y. [| \x. $(f 'y) |] -- Not ok (same reason)
- [| \x. $(f 'x) |] -- OK
+ [| \x. $(f 'x) |] -- OK
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)
+ * 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
+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.
%************************************************************************
-%* *
+%* *
\subsection{Main interface + stubs for the non-GHCI case
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -301,7 +294,7 @@ tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
- -- None of these functions add constraints to the LIE
+ -- None of these functions add constraints to the LIE
lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
@@ -329,27 +322,27 @@ runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Quoting an expression}
-%* *
+%* *
%************************************************************************
\begin{code}
-- See Note [How brackets and nested splices are handled]
-tcBracket brack res_ty
+tcBracket brack res_ty
= addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr brack)) $
- do { -- Check for nested brackets
+ do { -- Check for nested brackets
cur_stage <- getStage
- ; checkTc (not (isBrackStage cur_stage)) illegalBracket
+ ; checkTc (not (isBrackStage cur_stage)) illegalBracket
- -- Brackets are desugared to code that mentions the TH package
+ -- Brackets are desugared to code that mentions the TH package
; recordThUse
- -- Typecheck expr to make sure it is valid,
- -- but throw away the results. We'll type check
- -- it again when we actually use it.
+ -- Typecheck expr to make sure it is valid,
+ -- but throw away the results. We'll type check
+ -- it again when we actually use it.
; pending_splices <- newMutVar []
; lie_var <- getConstraintVar
; let brack_stage = Brack cur_stage pending_splices lie_var
@@ -359,21 +352,21 @@ tcBracket brack res_ty
-- instance), but we aren't otherwise interested in the
-- results. Nor do we care about ambiguous dictionaries etc.
-- We will type check this bracket again at its usage site.
- --
- -- We build a single implication constraint with a BracketSkol;
- -- that in turn tells simplifyCheck to report only definite
- -- errors
+ --
+ -- We build a single implication constraint with a BracketSkol;
+ -- that in turn tells simplifyCheck to report only definite
+ -- errors
; (_,lie) <- captureConstraints $
- newImplication BracketSkol [] [] $
- setStage brack_stage $
- do { meta_ty <- tc_bracket cur_stage brack
- ; unifyType meta_ty res_ty }
-
- -- It's best to simplify the constraint now, even though in
- -- principle some later unification might be useful for it,
- -- because we don't want these essentially-junk TH implication
- -- contraints floating around nested inside other constraints
- -- See for example Trac #4949
+ newImplication BracketSkol [] [] $
+ setStage brack_stage $
+ do { meta_ty <- tc_bracket cur_stage brack
+ ; unifyType meta_ty res_ty }
+
+ -- It's best to simplify the constraint now, even though in
+ -- principle some later unification might be useful for it,
+ -- because we don't want these essentially-junk TH implication
+ -- contraints floating around nested inside other constraints
+ -- See for example Trac #4949
; _ <- simplifyTop lie
-- Return the original expression, not the type-decorated one
@@ -381,92 +374,92 @@ tcBracket brack res_ty
; return (noLoc (HsBracketOut brack pendings)) }
tc_bracket :: ThStage -> HsBracket Name -> TcM TcType
-tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
- = do { thing <- tcLookup name
- ; case thing of
- AGlobal _ -> return ()
- ATcId { tct_level = bind_lvl, tct_id = id }
- | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
- -> keepAliveTc id
- | otherwise
- -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
- (quotedNameStageErr name) }
- _ -> pprPanic "th_bracket" (ppr name)
-
- ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
- }
-
-tc_bracket _ (ExpBr expr)
- = do { any_ty <- newFlexiTyVarTy openTypeKind
- ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
- ; tcMetaTy expQTyConName }
- -- Result type is ExpQ (= Q Exp)
-
-tc_bracket _ (TypBr typ)
- = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
- ; tcMetaTy typeQTyConName }
- -- Result type is Type (= Q Typ)
+tc_bracket outer_stage (VarBr name) -- Note [Quoting names]
+ = do { thing <- tcLookup name
+ ; case thing of
+ AGlobal _ -> return ()
+ ATcId { tct_level = bind_lvl, tct_id = id }
+ | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting
+ -> keepAliveTc id
+ | otherwise
+ -> do { checkTc (thLevel outer_stage + 1 == bind_lvl)
+ (quotedNameStageErr name) }
+ _ -> pprPanic "th_bracket" (ppr name)
+
+ ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
+ }
+
+tc_bracket _ (ExpBr expr)
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
+ ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
+ ; tcMetaTy expQTyConName }
+ -- Result type is ExpQ (= Q Exp)
+
+tc_bracket _ (TypBr typ)
+ = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
+ ; tcMetaTy typeQTyConName }
+ -- Result type is Type (= Q Typ)
tc_bracket _ (DecBrG decls)
- = do { _ <- tcTopSrcDecls emptyModDetails decls
- -- Typecheck the declarations, dicarding the result
- -- We'll get all that stuff later, when we splice it in
+ = do { _ <- tcTopSrcDecls emptyModDetails decls
+ -- Typecheck the declarations, dicarding the result
+ -- We'll get all that stuff later, when we splice it in
- -- Top-level declarations in the bracket get unqualified names
+ -- Top-level declarations in the bracket get unqualified names
-- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
- ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
+ ; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
tc_bracket _ (PatBr pat)
- = do { any_ty <- newFlexiTyVarTy openTypeKind
- ; _ <- tcPat ThPatQuote pat any_ty $
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
+ ; _ <- tcPat ThPatQuote pat any_ty $
return ()
- ; tcMetaTy patQTyConName }
- -- Result type is PatQ (= Q Pat)
+ ; tcMetaTy patQTyConName }
+ -- Result type is PatQ (= Q Pat)
tc_bracket _ (DecBrL _)
= panic "tc_bracket: Unexpected DecBrL"
quotedNameStageErr :: Name -> SDoc
-quotedNameStageErr v
+quotedNameStageErr v
= 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")]
+ , ptext (sLit "must be used at the same stage at which is is bound")]
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Splicing an expression}
-%* *
+%* *
%************************************************************************
\begin{code}
tcSpliceExpr (HsSplice name expr) res_ty
- = setSrcSpan (getLoc expr) $ do
+ = setSrcSpan (getLoc expr) $ do
{ stage <- getStage
; case stage of {
- Splice -> tcTopSplice expr res_ty ;
- Comp -> tcTopSplice expr res_ty ;
+ Splice -> tcTopSplice expr res_ty ;
+ Comp -> tcTopSplice expr res_ty ;
- Brack pop_stage ps_var lie_var -> do
+ Brack pop_stage ps_var lie_var -> do
-- See Note [How brackets and nested splices are handled]
- -- A splice inside brackets
- -- NB: ignore res_ty, apart from zapping it to a mono-type
- -- e.g. [| reverse $(h 4) |]
- -- Here (h 4) :: Q Exp
- -- but $(h 4) :: forall a.a i.e. anything!
+ -- A splice inside brackets
+ -- NB: ignore res_ty, apart from zapping it to a mono-type
+ -- e.g. [| reverse $(h 4) |]
+ -- Here (h 4) :: Q Exp
+ -- but $(h 4) :: forall a.a i.e. anything!
{ meta_exp_ty <- tcMetaTy expQTyConName
; expr' <- setStage pop_stage $
setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
- -- Write the pending splice into the bucket
+ -- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; writeMutVar ps_var ((name,expr') : ps)
- ; return (panic "tcSpliceExpr") -- The returned expression is ignored
+ ; return (panic "tcSpliceExpr") -- The returned expression is ignored
}}}
tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
@@ -483,10 +476,10 @@ tcTopSplice expr res_ty
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- ; addErrCtxt (spliceResultDoc expr) $ do
+ ; addErrCtxt (spliceResultDoc expr) $ do
{ (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
- ; exp4 <- tcMonoExpr exp3 res_ty
+ ; exp4 <- tcMonoExpr exp3 res_ty
; return (unLoc exp4) } }
spliceResultDoc :: LHsExpr Name -> SDoc
@@ -502,110 +495,110 @@ tcTopSpliceExpr :: TcM (LHsExpr Id) -> TcM (LHsExpr Id)
-- (the caller will compile and run it)
-- Note that set the level to Splice, regardless of the original level,
-- before typechecking the expression. For example:
--- f x = $( ...$(g 3) ... )
--- The recursive call to tcMonoExpr will simply expand the
+-- f x = $( ...$(g 3) ... )
+-- The recursive call to tcMonoExpr will simply expand the
-- inner escape before dealing with the outer one
tcTopSpliceExpr tc_action
= checkNoErrs $ -- checkNoErrs: must not try to run the thing
-- if the type checker fails!
- setStage Splice $
+ setStage Splice $
do { -- Typecheck the expression
(expr', lie) <- captureConstraints tc_action
-
- -- Solve the constraints
- ; const_binds <- simplifyTop lie
-
+
+ -- Solve the constraints
+ ; const_binds <- simplifyTop lie
+
-- Zonk it and tie the knot of dictionary bindings
; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
\end{code}
%************************************************************************
-%* *
- Splicing a type
-%* *
+%* *
+ Splicing a type
+%* *
%************************************************************************
Very like splicing an expression, but we don't yet share code.
\begin{code}
kcSpliceType splice@(HsSplice name hs_expr) fvs
- = setSrcSpan (getLoc hs_expr) $ do
+ = setSrcSpan (getLoc hs_expr) $ do
{ stage <- getStage
; case stage of {
Splice -> kcTopSpliceType hs_expr ;
- Comp -> kcTopSpliceType hs_expr ;
+ Comp -> kcTopSpliceType hs_expr ;
- Brack pop_level ps_var lie_var -> do
- -- See Note [How brackets and nested splices are handled]
- -- A splice inside brackets
+ Brack pop_level ps_var lie_var -> do
+ -- See Note [How brackets and nested splices are handled]
+ -- A splice inside brackets
{ meta_ty <- tcMetaTy typeQTyConName
; expr' <- setStage pop_level $
- setConstraintVar lie_var $
- tcMonoExpr hs_expr meta_ty
+ setConstraintVar lie_var $
+ tcMonoExpr hs_expr meta_ty
- -- Write the pending splice into the bucket
+ -- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; writeMutVar ps_var ((name,expr') : ps)
-- e.g. [| f (g :: Int -> $(h 4)) |]
-- Here (h 4) :: Q Type
- -- but $(h 4) :: a i.e. any type, of any kind
+ -- but $(h 4) :: a i.e. any type, of any kind
; kind <- newKindVar
- ; return (HsSpliceTy splice fvs kind, kind)
+ ; return (HsSpliceTy splice fvs kind, kind)
}}}
kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
-- Note [How top-level splices are handled]
kcTopSpliceType expr
- = do { meta_ty <- tcMetaTy typeQTyConName
-
- -- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
-
- -- Run the expression
- ; hs_ty2 <- runMetaT zonked_q_expr
- ; showSplice "type" expr (ppr hs_ty2)
-
- -- Rename it, but bale out if there are errors
- -- otherwise the type checker just gives more spurious errors
- ; addErrCtxt (spliceResultDoc expr) $ do
- { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
- ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
- ; (ty4, kind) <- kcLHsType hs_ty3
+ = do { meta_ty <- tcMetaTy typeQTyConName
+
+ -- Typecheck the expression
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_ty)
+
+ -- Run the expression
+ ; hs_ty2 <- runMetaT zonked_q_expr
+ ; showSplice "type" expr (ppr hs_ty2)
+
+ -- Rename it, but bale out if there are errors
+ -- otherwise the type checker just gives more spurious errors
+ ; addErrCtxt (spliceResultDoc expr) $ do
+ { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
+ ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
+ ; (ty4, kind) <- kcLHsType hs_ty3
; return (unLoc ty4, kind) }}
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Splicing an expression}
-%* *
+%* *
%************************************************************************
\begin{code}
-- Note [How top-level splices are handled]
-- Always at top level
-- Type sig at top of file:
--- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
+-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceDecls expr
- = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
- ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
+ = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec]
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr list_q)
- -- Run the expression
- ; decls <- runMetaD zonked_q_expr
- ; showSplice "declarations" expr
- (ppr (getLoc expr) $$ (vcat (map ppr decls)))
+ -- Run the expression
+ ; decls <- runMetaD zonked_q_expr
+ ; showSplice "declarations" expr
+ (ppr (getLoc expr) $$ (vcat (map ppr decls)))
- ; return decls }
+ ; return decls }
\end{code}
%************************************************************************
-%* *
- Annotations
-%* *
+%* *
+ Annotations
+%* *
%************************************************************************
\begin{code}
@@ -614,18 +607,18 @@ runAnnotation target expr = do
loc <- getSrcSpanM
data_class <- tcLookupClass dataClassName
to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
-
+
-- 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
- zonked_wrapped_expr' <- tcTopSpliceExpr $
+ zonked_wrapped_expr' <- tcTopSpliceExpr $
do { (expr', expr_ty) <- tcInferRhoNC expr
- -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
- -- By instantiating the call >here< it gets registered in the
- -- LIE consulted by tcTopSpliceExpr
+ -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+ -- By instantiating the call >here< it gets registered in the
+ -- LIE consulted by tcTopSpliceExpr
-- and hence ensures the appropriate dictionary is bound by const_binds
; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
- ; let specialised_to_annotation_wrapper_expr
+ ; let specialised_to_annotation_wrapper_expr
= L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) }
@@ -636,13 +629,13 @@ runAnnotation target expr = do
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 {
+ -- 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
}
@@ -650,9 +643,9 @@ runAnnotation target expr = do
%************************************************************************
-%* *
- Quasi-quoting
-%* *
+%* *
+ Quasi-quoting
+%* *
%************************************************************************
Note [Quasi-quote overview]
@@ -662,30 +655,30 @@ The GHC "quasi-quote" extension is described by Geoff Mainland's paper
Workshop 2007).
Briefly, one writes
- [p| stuff |]
+ [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")
+ $(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.
%************************************************************************
-%* *
+%* *
\subsubsection{Quasiquotation}
-%* *
+%* *
%************************************************************************
See Note [Quasi-quote overview] in TcSplice.
\begin{code}
runQuasiQuote :: Outputable hs_syn
- => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
- -> Name -- Of type QuasiQuoter -> String -> Q th_syn
- -> Name -- Name of th_syn type
- -> MetaOps th_syn hs_syn
+ => HsQuasiQuote RdrName -- Contains term of type QuasiQuoter, and the String
+ -> Name -- Of type QuasiQuoter -> String -> Q th_syn
+ -> Name -- Name of th_syn type
+ -> MetaOps th_syn hs_syn
-> RnM hs_syn
runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
= do { -- Drop the leading "$" from the quoter name, if present
@@ -699,40 +692,40 @@ runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
; quoter' <- lookupOccRn quoter
- -- We use lookupOcc rather than lookupGlobalOcc because in the
- -- erroneous case of \x -> [x| ...|] we get a better error message
- -- (stage restriction rather than out of scope).
+ -- We use lookupOcc rather than lookupGlobalOcc because in the
+ -- erroneous case of \x -> [x| ...|] we get a better error message
+ -- (stage restriction rather than out of scope).
- ; when (isUnboundName quoter') failM
- -- If 'quoter' is not in scope, proceed no further
- -- The error message was generated by lookupOccRn, but it then
- -- succeeds with an "unbound name", which makes the subsequent
- -- attempt to run the quote fail in a confusing way
+ ; when (isUnboundName quoter') failM
+ -- If 'quoter' is not in scope, proceed no further
+ -- The error message was generated by lookupOccRn, but it then
+ -- succeeds with an "unbound name", which makes the subsequent
+ -- attempt to run the quote fail in a confusing way
-- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
- ; this_mod <- getModule
+ ; this_mod <- getModule
; let is_local = nameIsLocalOrFrom this_mod quoter'
; checkTc (not is_local) (quoteStageError quoter')
- ; traceTc "runQQ" (ppr quoter <+> ppr is_local)
+ ; traceTc "runQQ" (ppr quoter <+> ppr is_local)
- -- 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
- ; meta_exp_ty <- tcMetaTy meta_ty
+ -- 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
+ ; meta_exp_ty <- tcMetaTy meta_ty
- -- Typecheck the expression
- ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
+ -- Typecheck the expression
+ ; zonked_q_expr <- tcTopSpliceExpr (tcMonoExpr expr meta_exp_ty)
- -- Run the expression
- ; result <- runMetaQ meta_ops zonked_q_expr
- ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
+ -- Run the expression
+ ; result <- runMetaQ meta_ops zonked_q_expr
+ ; showSplice (mt_desc meta_ops) quoteExpr (ppr result)
- ; return result }
+ ; return result }
runQuasiQuoteExpr qq = runQuasiQuote qq quoteExpName expQTyConName exprMetaOps
runQuasiQuotePat qq = runQuasiQuote qq quotePatName patQTyConName patMetaOps
@@ -753,17 +746,17 @@ deprecatedDollar quoter
%************************************************************************
-%* *
+%* *
\subsection{Running an expression}
-%* *
+%* *
%************************************************************************
\begin{code}
data MetaOps th_syn hs_syn
- = MT { mt_desc :: String -- Type of beast (expression, type etc)
+ = MT { mt_desc :: String -- Type of beast (expression, type etc)
, mt_show :: th_syn -> String -- How to show the th_syn thing
, mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn
- -- How to convert to hs_syn
+ -- How to convert to hs_syn
}
exprMetaOps :: MetaOps TH.Exp (LHsExpr RdrName)
@@ -788,10 +781,10 @@ runMetaAW k = runMeta False (\_ -> return . Right . k)
-- the toAnnotationWrapper function that we slap around the users code
-----------------
-runMetaQ :: Outputable hs_syn
+runMetaQ :: Outputable hs_syn
=> MetaOps th_syn hs_syn
- -> LHsExpr Id
- -> TcM hs_syn
+ -> LHsExpr Id
+ -> TcM hs_syn
runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
= runMeta True run_and_cvt expr
where
@@ -800,100 +793,100 @@ runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
; traceTc "Got TH result:" (text (show_th th_result))
; return (cvt expr_span th_result) }
-runMetaE :: LHsExpr Id -- Of type (Q Exp)
- -> TcM (LHsExpr RdrName)
+runMetaE :: LHsExpr Id -- Of type (Q Exp)
+ -> TcM (LHsExpr RdrName)
runMetaE = runMetaQ exprMetaOps
-runMetaT :: LHsExpr Id -- Of type (Q Type)
- -> TcM (LHsType RdrName)
+runMetaT :: LHsExpr Id -- Of type (Q Type)
+ -> TcM (LHsType RdrName)
runMetaT = runMetaQ typeMetaOps
-runMetaD :: LHsExpr Id -- Of type Q [Dec]
- -> TcM [LHsDecl RdrName]
+runMetaD :: LHsExpr Id -- Of type Q [Dec]
+ -> TcM [LHsDecl RdrName]
runMetaD = runMetaQ declMetaOps
---------------
runMeta :: (Outputable hs_syn)
=> Bool -- Whether code should be printed in the exception message
- -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x
- -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
- -> TcM hs_syn -- Of type t
+ -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x
+ -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
+ -> TcM hs_syn -- Of type t
runMeta show_code run_and_convert expr
- = do { traceTc "About to run" (ppr expr)
+ = do { traceTc "About to run" (ppr expr)
; recordThSpliceUse -- seems to be the best place to do this,
-- we catch all kinds of splices and annotations.
- -- Check that we've had no errors of any sort so far.
- -- For example, if we found an error in an earlier defn f, but
- -- recovered giving it type f :: forall a.a, it'd be very dodgy
- -- to carry ont. Mind you, the staging restrictions mean we won't
- -- actually run f, but it still seems wrong. And, more concretely,
- -- see Trac #5358 for an example that fell over when trying to
- -- reify a function with a "?" kind in it. (These don't occur
- -- in type-correct programs.
- ; failIfErrsM
-
- -- Desugar
- ; ds_expr <- initDsTc (dsLExpr expr)
- -- Compile and link it; might fail if linking fails
- ; hsc_env <- getTopEnv
- ; src_span <- getSrcSpanM
- ; traceTc "About to run (desugared)" (ppr ds_expr)
+ -- Check that we've had no errors of any sort so far.
+ -- For example, if we found an error in an earlier defn f, but
+ -- recovered giving it type f :: forall a.a, it'd be very dodgy
+ -- to carry ont. Mind you, the staging restrictions mean we won't
+ -- actually run f, but it still seems wrong. And, more concretely,
+ -- see Trac #5358 for an example that fell over when trying to
+ -- reify a function with a "?" kind in it. (These don't occur
+ -- in type-correct programs.
+ ; failIfErrsM
+
+ -- Desugar
+ ; ds_expr <- initDsTc (dsLExpr expr)
+ -- Compile and link it; might fail if linking fails
+ ; hsc_env <- getTopEnv
+ ; src_span <- getSrcSpanM
+ ; traceTc "About to run (desugared)" (ppr ds_expr)
; either_hval <- tryM $ liftIO $
- HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
- ; case either_hval of {
- Left exn -> failWithTc (mk_msg "compile and link" exn) ;
- Right hval -> do
-
- { -- Coerce it to Q t, and run it
-
- -- 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
- --
- -- 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
- -- encounter them inside the try
- --
- -- See Note [Exceptions in TH]
- let expr_span = getLoc expr
- ; either_tval <- tryAllM $
- setSrcSpan expr_span $ -- Set the span so that qLocation can
- -- see where this splice is
- do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
- ; case mb_result of
- Left err -> failWithTc err
- Right result -> do { traceTc "Got HsSyn result:" (ppr result)
+ HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
+ ; case either_hval of {
+ Left exn -> failWithTc (mk_msg "compile and link" exn) ;
+ Right hval -> do
+
+ { -- Coerce it to Q t, and run it
+
+ -- 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
+ --
+ -- 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
+ -- encounter them inside the try
+ --
+ -- See Note [Exceptions in TH]
+ let expr_span = getLoc expr
+ ; either_tval <- tryAllM $
+ setSrcSpan expr_span $ -- Set the span so that qLocation can
+ -- see where this splice is
+ do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
+ ; case mb_result of
+ Left err -> failWithTc err
+ Right result -> do { traceTc "Got HsSyn result:" (ppr result)
; return $! result } }
- ; case either_tval of
- Right v -> return v
- Left se -> case fromException se of
- Just IOEnvFailure -> failM -- Error already in Tc monad
- _ -> failWithTc (mk_msg "run" se) -- Exception
+ ; case either_tval of
+ Right v -> return v
+ Left se -> case fromException se of
+ Just IOEnvFailure -> failM -- Error already in Tc monad
+ _ -> failWithTc (mk_msg "run" se) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
- nest 2 (text (Panic.showException exn)),
- if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
+ nest 2 (text (Panic.showException exn)),
+ if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
\end{code}
Note [Exceptions in TH]
~~~~~~~~~~~~~~~~~~~~~~~
-Supppose we have something like this
- $( f 4 )
+Supppose we have something like this
+ $( f 4 )
where
- f :: Int -> Q [Dec]
- f n | n>3 = fail "Too many declarations"
- | otherwise = ...
+ 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
+ effectively transforms (fail s) to
+ qReport True s >> fail
where 'qReport' comes from the Quasi class and fail from its monad
superclass.
@@ -901,10 +894,10 @@ like that. Here's how it's processed:
(qReport True s) by using addErr to add an error message to the bag of errors.
The 'fail' in TcM raises an IOEnvFailure exception
- * So, when running a splice, we catch all exceptions; then for
- - an IOEnvFailure exception, we assume the error is already
- in the error-bag (above)
- - other errors, we add an error to the bag
+ * So, when running a splice, we catch all exceptions; then for
+ - an IOEnvFailure exception, we assume the error is already
+ in the error-bag (above)
+ - other errors, we add an error to the bag
and then fail
@@ -912,9 +905,9 @@ To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
\begin{code}
instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
- qNewName s = do { u <- newUnique
- ; let i = getKey u
- ; return (TH.mkNameU s i) }
+ qNewName s = do { u <- newUnique
+ ; let i = getKey u
+ ; return (TH.mkNameU s i) }
qReport True msg = addErr (text msg)
qReport False msg = addReport (text msg) empty
@@ -935,24 +928,24 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
qReify = reify
qReifyInstances = reifyInstances
- -- For qRecover, discard error messages if
- -- the recovery action is chosen. Otherwise
- -- we'll only fail higher up. c.f. tryTcLIE_
+ -- 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
- }
+ ; case mb_res of
+ Just val -> do { addMessages msgs -- There might be warnings
+ ; return val }
+ Nothing -> recover -- Discard all msgs
+ }
qRunIO io = liftIO io
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Errors and contexts}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -960,35 +953,35 @@ 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
+-- 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])]) }
+ ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
+ nest 2 (sep [nest 2 (ppr before),
+ text "======>",
+ nest 2 after])]) }
illegalBracket :: SDoc
illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
-#endif /* GHCI */
+#endif /* GHCI */
\end{code}
%************************************************************************
-%* *
- Instance Testing
-%* *
+%* *
+ Instance Testing
+%* *
%************************************************************************
\begin{code}
reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
reifyInstances th_nm th_tys
- = addErrCtxt (ptext (sLit "In reifyInstances")
+ = addErrCtxt (ptext (sLit "In reifyInstances")
<+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
do { thing <- getThing th_nm
; case thing of
- AGlobal (ATyCon tc)
+ AGlobal (ATyCon tc)
| Just cls <- tyConClass_maybe tc
-> do { tys <- tc_types (classTyCon cls) th_tys
; inst_envs <- tcGetInstEnvs
@@ -998,7 +991,7 @@ reifyInstances th_nm th_tys
-> do { tys <- tc_types tc th_tys
; inst_envs <- tcGetFamInstEnvs
; let matches = lookupFamInstEnv inst_envs tc tys
- ; mapM (reifyFamilyInstance . fst) matches }
+ ; mapM (reifyFamilyInstance . fst) matches }
_ -> bale_out (ppr_th th_nm <+> ptext (sLit "is not a class or type constructor"))
}
where
@@ -1008,13 +1001,13 @@ reifyInstances th_nm th_tys
tc_types :: TyCon -> [TH.Type] -> TcM [Type]
tc_types tc th_tys
= do { let tc_arity = tyConArity tc
- ; when (length th_tys /= tc_arity)
+ ; when (length th_tys /= tc_arity)
(bale_out (ptext (sLit "Wrong number of types (expected")
<+> int tc_arity <> rparen))
; loc <- getSrcSpanM
- ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName
+ ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName
; rn_tys <- rnLHsTypes doc rdr_tys -- Rename to HsType Name
- ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys
+ ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys
; mapM dsHsType tys }
cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName)
@@ -1025,15 +1018,15 @@ reifyInstances th_nm th_tys
%************************************************************************
-%* *
- Reification
-%* *
+%* *
+ Reification
+%* *
%************************************************************************
\begin{code}
-lookupName :: Bool -- True <=> type namespace
- -- False <=> value namespace
+lookupName :: Bool -- True <=> type namespace
+ -- False <=> value namespace
-> String -> TcM (Maybe TH.Name)
lookupName is_type_name s
= do { lcl_env <- getLocalRdrEnv
@@ -1042,16 +1035,16 @@ lookupName is_type_name s
Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
; return (fmap reifyName mb_nm) } }
where
- th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
+ th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M'
occ_fs :: FastString
occ_fs = mkFastString (TH.nameBase th_name)
occ :: OccName
- occ | is_type_name
- = if isLexCon occ_fs then mkTcOccFS occ_fs
+ occ | is_type_name
+ = if isLexCon occ_fs then mkTcOccFS occ_fs
else mkTyVarOccFS occ_fs
- | otherwise
+ | otherwise
= if isLexCon occ_fs then mkDataOccFS occ_fs
else mkVarOccFS occ_fs
@@ -1060,12 +1053,12 @@ lookupName is_type_name s
Just mod -> mkRdrQual (mkModuleName mod) occ
getThing :: TH.Name -> TcM TcTyThing
-getThing th_name
- = do { name <- lookupThName th_name
- ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
- ; tcLookupTh name }
- -- ToDo: this tcLookup could fail, which would give a
- -- rather unhelpful error message
+getThing th_name
+ = do { name <- lookupThName th_name
+ ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
+ ; tcLookupTh name }
+ -- ToDo: this tcLookup could fail, which would give a
+ -- rather unhelpful error message
where
ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
@@ -1074,8 +1067,8 @@ getThing th_name
reify :: TH.Name -> TcM TH.Info
reify th_name
- = do { thing <- getThing th_name
- ; reifyThing thing }
+ = do { thing <- getThing th_name
+ ; reifyThing thing }
lookupThName :: TH.Name -> TcM Name
lookupThName th_name = do
@@ -1087,51 +1080,51 @@ lookupThName th_name = do
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) }
+ -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
+ ; return (listToMaybe names) }
where
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)
- Nothing -> lookupGlobalOccRn_maybe 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)
+ Nothing -> lookupGlobalOccRn_maybe rdr_name }
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
- ; case lookupNameEnv (tcl_env lcl_env) name of {
- Just thing -> return thing;
- 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
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; case lookupNameEnv (tcl_env lcl_env) name of {
+ Just thing -> return thing;
+ 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
; dflags <- getDOpts
- ; case lookupType dflags hpt (eps_PTE eps) name of
- Just thing -> return (AGlobal thing)
- Nothing -> do { thing <- tcImportDecl name
- ; return (AGlobal thing) }
- -- Imported names should always be findable;
- -- if not, we fail hard in tcImportDecl
+ ; case lookupType dflags hpt (eps_PTE eps) name of
+ Just thing -> return (AGlobal thing)
+ Nothing -> do { thing <- tcImportDecl name
+ ; return (AGlobal thing) }
+ -- Imported names should always be findable;
+ -- if not, we fail hard in tcImportDecl
}}}}
notInScope :: TH.Name -> SDoc
-notInScope th_name = quotes (text (TH.pprint th_name)) <+>
- ptext (sLit "is not in scope at a reify")
- -- Ugh! Rather an indirect way to display the name
+notInScope th_name = quotes (text (TH.pprint th_name)) <+>
+ ptext (sLit "is not in scope at a reify")
+ -- Ugh! Rather an indirect way to display the name
notInEnv :: Name -> SDoc
-notInEnv name = quotes (ppr name) <+>
- ptext (sLit "is not in the type environment at a reify")
+notInEnv name = quotes (ppr name) <+>
+ ptext (sLit "is not in the type environment at a reify")
------------------------------
reifyThing :: TcTyThing -> TcM TH.Info
@@ -1140,35 +1133,35 @@ reifyThing :: TcTyThing -> TcM TH.Info
-- some random GHC extension
reifyThing (AGlobal (AnId id))
- = do { ty <- reifyType (idType id)
- ; fix <- reifyFixity (idName id)
- ; let v = reifyName id
- ; case idDetails id of
- ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
- _ -> return (TH.VarI v ty Nothing fix)
+ = do { ty <- reifyType (idType id)
+ ; fix <- reifyFixity (idName id)
+ ; let v = reifyName id
+ ; case idDetails id of
+ ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
+ _ -> return (TH.VarI v ty Nothing fix)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
reifyThing (AGlobal (ADataCon dc))
- = do { let name = dataConName dc
- ; ty <- reifyType (idType (dataConWrapId dc))
- ; fix <- reifyFixity name
- ; return (TH.DataConI (reifyName name) ty
- (reifyName (dataConOrigTyCon dc)) fix)
+ = do { let name = dataConName dc
+ ; ty <- reifyType (idType (dataConWrapId dc))
+ ; fix <- reifyFixity name
+ ; return (TH.DataConI (reifyName name) ty
+ (reifyName (dataConOrigTyCon dc)) fix)
}
-reifyThing (ATcId {tct_id = id})
- = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
- -- though it may be incomplete
- ; ty2 <- reifyType ty1
- ; fix <- reifyFixity (idName id)
- ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
+reifyThing (ATcId {tct_id = id})
+ = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
+ -- though it may be incomplete
+ ; ty2 <- reifyType ty1
+ ; fix <- reifyFixity (idName id)
+ ; return (TH.VarI (reifyName id) ty2 Nothing fix) }
-reifyThing (ATyVar tv ty)
- = do { ty1 <- zonkTcType ty
- ; ty2 <- reifyType ty1
- ; return (TH.TyVarI (reifyName tv) ty2) }
+reifyThing (ATyVar tv ty)
+ = do { ty1 <- zonkTcType ty
+ ; ty2 <- reifyType ty1
+ ; return (TH.TyVarI (reifyName tv) ty2) }
reifyThing (AThing {}) = panic "reifyThing AThing"
@@ -1180,7 +1173,7 @@ reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
; rhs' <- reifyType rhs
; return (TH.TyConI (TH.TySynInstD (reifyName tc) args' rhs') )}
| otherwise
- = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
<+> dcolon <+> pprEqPred (Pair lhs rhs))
reifyTyCon :: TyCon -> TcM TH.Info
@@ -1188,10 +1181,10 @@ reifyTyCon tc
| Just cls <- tyConClass_maybe tc
= reifyClass cls
- | isFunTyCon tc
- = return (TH.PrimTyConI (reifyName tc) 2 False)
+ | isFunTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) 2 False)
- | isPrimTyCon tc
+ | isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isFamilyTyCon tc
@@ -1204,73 +1197,73 @@ reifyTyCon tc
; fam_envs <- tcGetFamInstEnvs
; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc)
- ; return (TH.FamilyI
+ ; return (TH.FamilyI
(TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
instances) }
| isSynTyCon tc
- = do { let (tvs, rhs) = synTyConDefn tc
+ = do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
- ; return (TH.TyConI
- (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs'))
+ ; return (TH.TyConI
+ (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs'))
}
| otherwise
- = do { cxt <- reifyCxt (tyConStupidTheta tc)
- ; let tvs = tyConTyVars tc
- ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
- ; let name = reifyName tc
- r_tvs = reifyTyVars tvs
- deriv = [] -- Don't know about deriving
- decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
- | otherwise = TH.DataD cxt name r_tvs cons deriv
- ; return (TH.TyConI decl) }
+ = do { cxt <- reifyCxt (tyConStupidTheta tc)
+ ; let tvs = tyConTyVars tc
+ ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
+ ; let name = reifyName tc
+ r_tvs = reifyTyVars tvs
+ deriv = [] -- Don't know about deriving
+ decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
+ | otherwise = TH.DataD cxt name r_tvs cons deriv
+ ; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
-- For GADTs etc, see Note [Reifying data constructors]
reifyDataCon tys dc
= do { let (tvs, theta, arg_tys, _) = dataConSig dc
- subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs
+ subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs
(subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
theta' = substTheta subst' theta
arg_tys' = substTys subst' arg_tys
stricts = map reifyStrict (dataConStrictMarks dc)
- fields = dataConFieldLabels dc
- name = reifyName dc
+ fields = dataConFieldLabels dc
+ name = reifyName dc
; r_arg_tys <- reifyTypes arg_tys'
- ; let main_con | not (null fields)
+ ; let main_con | not (null fields)
= TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
| dataConIsInfix dc
= ASSERT( length arg_tys == 2 )
- TH.InfixC (s1,r_a1) name (s2,r_a2)
+ TH.InfixC (s1,r_a1) name (s2,r_a2)
| otherwise
= TH.NormalC name (stricts `zip` r_arg_tys)
- [r_a1, r_a2] = r_arg_tys
- [s1, s2] = stricts
+ [r_a1, r_a2] = r_arg_tys
+ [s1, s2] = stricts
; ASSERT( length arg_tys == length stricts )
if null ex_tvs' && null theta then
- return main_con
+ return main_con
else do
{ cxt <- reifyCxt theta'
- ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
+ ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
------------------------------
reifyClass :: Class -> TcM TH.Info
-reifyClass cls
- = do { cxt <- reifyCxt theta
+reifyClass cls
+ = do { cxt <- reifyCxt theta
; inst_envs <- tcGetInstEnvs
; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
- ; ops <- mapM reify_op op_stuff
+ ; ops <- mapM reify_op op_stuff
; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
- ; return (TH.ClassI dec insts ) }
+ ; return (TH.ClassI dec insts ) }
where
(tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
reify_op (op, _) = do { ty <- reifyType (idType op)
- ; return (TH.SigD (reifyName op) ty) }
+ ; return (TH.SigD (reifyName op) ty) }
------------------------------
reifyClassInstance :: Instance -> TcM TH.Dec
@@ -1285,7 +1278,7 @@ reifyClassInstance i
------------------------------
reifyFamilyInstance :: FamInst -> TcM TH.Dec
reifyFamilyInstance fi
- | isSynTyCon rep_tc
+ | isSynTyCon rep_tc
= do { th_tys <- reifyTypes (fi_tys fi)
; rhs_ty <- reifyType (synTyConType rep_tc)
; return (TH.TySynInstD fam th_tys rhs_ty) }
@@ -1295,18 +1288,18 @@ reifyFamilyInstance fi
fam = reifyName (fi_fam fi)
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
; th_tys <- reifyTypes (fi_tys fi)
- ; return (if isNewTyCon rep_tc
+ ; return (if isNewTyCon rep_tc
then TH.NewtypeInstD [] fam th_tys (head cons) []
else TH.DataInstD [] fam th_tys cons []) }
where
rep_tc = fi_tycon fi
fam = reifyName (fi_fam fi)
-
+
------------------------------
reifyType :: TypeRep.Type -> TcM TH.Type
-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
-reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
+reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType ty@(FunTy t1 t2)
@@ -1315,12 +1308,12 @@ reifyType ty@(FunTy t1 t2)
reify_for_all :: TypeRep.Type -> TcM TH.Type
reify_for_all ty
- = do { cxt' <- reifyCxt cxt;
- ; tau' <- reifyType tau
+ = do { cxt' <- reifyCxt cxt;
+ ; tau' <- reifyType tau
; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
where
- (tvs, cxt, tau) = tcSplitSigmaTy ty
-
+ (tvs, cxt, tau) = tcSplitSigmaTy ty
+
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
@@ -1333,7 +1326,7 @@ reifyKind ki
foldr TH.ArrowK ki'_rep kis_rep
where
reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
- | otherwise = pprPanic "Exotic form of kind"
+ | otherwise = pprPanic "Exotic form of kind"
(ppr k)
reifyCxt :: [PredType] -> TcM [TH.Pred]
@@ -1345,7 +1338,7 @@ reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyFamFlavour :: TyCon -> TH.FamFlavour
reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
| isFamilyTyCon tc = TH.DataFam
- | otherwise
+ | otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
@@ -1358,8 +1351,8 @@ reifyTyVars = map reifyTyVar
name = reifyName tv
reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
-reify_tc_app tc tys
- = do { tys' <- reifyTypes tys
+reify_tc_app tc tys
+ = do { tys' <- reifyTypes tys
; return (foldl TH.AppT r_tc tys') }
where
r_tc | isTupleTyCon tc = TH.TupleT (tyConArity tc)
@@ -1368,7 +1361,7 @@ reify_tc_app tc tys
reifyPred :: TypeRep.PredType -> TcM TH.Pred
reifyPred ty = case predTypePredTree ty of
- ClassPred cls tys -> do { tys' <- reifyTypes tys
+ ClassPred cls tys -> do { tys' <- reifyTypes tys
; return $ TH.ClassP (reifyName cls) tys' }
IPPred _ _ -> noTH (sLit "implicit parameters") (ppr ty)
EqPred ty1 ty2 -> do { ty1' <- reifyType ty1
@@ -1383,11 +1376,11 @@ reifyPred ty = case predTypePredTree ty of
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
| isExternalName name = mk_varg pkg_str mod_str occ_str
- | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
- -- 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.
+ | otherwise = TH.mkNameU occ_str (getKey (getUnique name))
+ -- 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.
where
name = getName thing
mod = ASSERT( isExternalName name ) nameModule name
@@ -1396,15 +1389,15 @@ reifyName thing
occ_str = occNameString occ
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)
+ | 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) }
+ = 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
@@ -1418,9 +1411,9 @@ reifyStrict bang | bang == HsUnpack = TH.Unpacked
------------------------------
noTH :: LitString -> SDoc -> TcM a
-noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
- ptext (sLit "in Template Haskell:"),
- nest 2 d])
+noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+>
+ ptext (sLit "in Template Haskell:"),
+ nest 2 d])
ppr_th :: TH.Ppr a => a -> SDoc
ppr_th x = text (TH.pprint x)
@@ -1428,7 +1421,7 @@ ppr_th x = text (TH.pprint x)
Note [Reifying data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Template Haskell syntax is rich enough to express even GADTs,
+Template Haskell syntax is rich enough to express even GADTs,
provided we do so in the equality-predicate form. So a GADT
like