diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-11-06 16:21:05 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-11-06 16:21:05 +0000 |
commit | bf3b29323d69b2c6f073885fb896dd4a5c346c02 (patch) | |
tree | 510f1c4a46dd368985566226c7055c9738afa0b5 | |
parent | 5bf435bd01981a65dba7c611cf8da327c8268738 (diff) | |
download | haskell-bf3b29323d69b2c6f073885fb896dd4a5c346c02.tar.gz |
Tidy up the error messages we get from TH in stage1 (Trac #8312)
Instead of panic-ing we now give a sensible message.
There is quite a bit of refactoring here too, removing
several #ifdef GHCI things
-rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
-rw-r--r-- | compiler/rename/RnExpr.lhs | 7 | ||||
-rw-r--r-- | compiler/rename/RnPat.lhs | 11 | ||||
-rw-r--r-- | compiler/rename/RnSource.lhs | 7 | ||||
-rw-r--r-- | compiler/rename/RnSplice.lhs | 53 | ||||
-rw-r--r-- | compiler/rename/RnSplice.lhs-boot | 4 | ||||
-rw-r--r-- | compiler/rename/RnTypes.lhs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcAnnotations.lhs | 12 | ||||
-rw-r--r-- | compiler/typecheck/TcExpr.lhs | 16 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.lhs | 26 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 14 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.lhs | 128 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.lhs-boot | 16 |
13 files changed, 125 insertions, 177 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ce1223b13a..70f7c1634d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -387,6 +387,7 @@ Library TcCanonical TcSMonad TcTypeNats + TcSplice Class Coercion FamInstEnv @@ -532,7 +533,6 @@ Library if flag(ghci) Exposed-Modules: DsMeta - TcSplice Convert ByteCodeAsm ByteCodeGen diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index cb36b9055a..32e0a47193 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -16,9 +16,7 @@ module RnExpr ( #include "HsVersions.h" -#ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) -#endif /* GHCI */ import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, rnGRHS, makeMiniFixityEnv) @@ -179,15 +177,12 @@ rnExpr e@(HsBracket br_body) = rnBracket e br_body rnExpr (HsSpliceE splice) = rnSpliceExpr splice -#ifndef GHCI -rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) -#else + rnExpr (HsQuasiQuoteE qq) = runQuasiQuoteExpr qq `thenM` \ lexpr' -> -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) rnExpr (HsPar lexpr') -#endif /* GHCI */ --------------------------------------------- -- Sections diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 16f94fe5a8..28879d301e 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -39,10 +39,8 @@ module RnPat (-- main entry points -- ENH: thin imports to only what is necessary for patterns import {-# SOURCE #-} RnExpr ( rnLExpr ) -#ifdef GHCI import {-# SOURCE #-} RnSplice ( rnSplicePat ) import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) -#endif /* GHCI */ #include "HsVersions.h" @@ -424,22 +422,15 @@ rnPatAndThen mk (TuplePat pats boxed _) ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed placeHolderType) } -#ifndef GHCI -rnPatAndThen _ p@(SplicePat {}) - = pprPanic "Can't do SplicePat without GHCi" (ppr p) -rnPatAndThen _ p@(QuasiQuotePat {}) - = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) -#else rnPatAndThen _ (SplicePat splice) = do { -- XXX How to deal with free variables? - (pat, _) <- liftCps $ rnSplicePat splice + ; (pat, _) <- liftCps $ rnSplicePat splice ; return pat } rnPatAndThen mk (QuasiQuotePat qq) = do { pat <- liftCps $ runQuasiQuotePat qq -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) ; rnPatAndThen mk (ParPat pat) } -#endif /* GHCI */ rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 43932b4904..44b88cb880 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -12,9 +12,7 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSpliceDecl ) -#ifdef GHCI import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) -#endif /* GHCI */ import HsSyn import RdrName @@ -1475,14 +1473,9 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds where badImplicitSplice = ptext (sLit "Parse error: naked expression at top level") -#ifndef GHCI -add _ _ (QuasiQuoteD qq) _ - = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq) -#else add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes = do { ds' <- runQuasiQuoteDecl qq ; addl gp (ds' ++ ds) } -#endif -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 01c4087df7..52cae5af75 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -5,11 +5,10 @@ module RnSplice ( checkThLocalName ) where -import FastString + import Name import NameSet import HsSyn -import Outputable import RdrName import TcRnMonad @@ -25,6 +24,8 @@ import RnSource ( rnSrcDecls, findSplice ) import RnTypes import SrcLoc import TcEnv ( checkWellStaged, tcLookup, tcMetaTy, thTopLevelId ) +import Outputable +import FastString import {-# SOURCE #-} RnExpr ( rnLExpr ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) @@ -35,29 +36,22 @@ import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) \begin{code} #ifndef GHCI rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) -rnBracket e _ = failTH e "bracket" +rnBracket e _ = failTH e "Template Haskell bracket" rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -rnSplice e = failTH e "splice" +rnSplice e = failTH e "Template Haskell splice" rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) -rnSpliceType e _ = failTH e "splice" +rnSpliceType e _ = failTH e "Template Haskell type splice" rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) -rnSpliceExpr e = failTH e "splice" +rnSpliceExpr e = failTH e "Template Haskell splice" rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) -rnSplicePat e = failTH e "splice" +rnSplicePat e = failTH e "Template Haskell pattern splice" rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) -rnSpliceDecl e = failTH e "splice" - -failTH :: Outputable a => a -> String -> RnM b -failTH e what -- Raise an error in a stage-1 compiler - = failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "requires GHC with interpreter support"), - ptext (sLit "Perhaps you are using a stage-1 compiler?"), - nest 2 (ppr e)]) +rnSpliceDecl e = failTH e "Template Haskell declaration splice" #else \end{code} @@ -89,7 +83,7 @@ type checker. Not very satisfactory really. \begin{code} rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnSplice (HsSplice isTyped n expr) - = do { checkTH expr "splice" + = do { checkTH expr "Template Haskell splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc n) ; (expr', fvs) <- rnLExpr expr @@ -124,13 +118,13 @@ rnSpliceType splice@(HsSplice isTypedSplice _ expr) k -- ToDo: deal with fvs ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $ rnSplice splice - + ; ps <- readMutVar ps_var ; writeMutVar ps_var (PendingRnTypeSplice name expr' : ps) ; return (HsSpliceTy splice' fvs k, fvs) } - ; _ -> + ; _ -> do { -- ToDo: deal with fvs (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $ setStage (Splice isTypedSplice) $ @@ -144,7 +138,7 @@ rnSpliceType splice@(HsSplice isTypedSplice _ expr) k maybeExpandTopSplice splice@(HsSplice True _ _) fvs = return (HsSpliceTy splice fvs k, fvs) - maybeExpandTopSplice (HsSplice False _ expr) _ + maybeExpandTopSplice (HsSplice False _ expr) _ = do { -- The splice must have type TypeQ ; meta_exp_ty <- tcMetaTy typeQTyConName @@ -180,13 +174,13 @@ rnSpliceExpr splice@(HsSplice isTypedSplice _ expr) ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $ rnSplice splice - + ; ps <- readMutVar ps_var ; writeMutVar ps_var (PendingRnExpSplice name expr' : ps) ; return (HsSpliceE splice', fvs) } - ; _ -> + ; _ -> do { (splice', fvs) <- addErrCtxt (spliceResultDoc expr) $ setStage (Splice isTypedSplice) $ rnSplice splice @@ -199,7 +193,7 @@ rnSpliceExpr splice@(HsSplice isTypedSplice _ expr) maybeExpandTopSplice splice@(HsSplice True _ _) fvs = return (HsSpliceE splice, fvs) - maybeExpandTopSplice (HsSplice False _ expr) _ + maybeExpandTopSplice (HsSplice False _ expr) _ = do { -- The splice must have type ExpQ ; meta_exp_ty <- tcMetaTy expQTyConName @@ -307,7 +301,7 @@ rnBracket e br_body ; unless thEnabled $ failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e , ptext (sLit "Perhaps you intended to use TemplateHaskell") ] ) - ; checkTH e "bracket" + ; checkTH e "Template Haskell bracket" -- Check for nested brackets ; cur_stage <- getStage @@ -470,19 +464,6 @@ spliceResultDoc expr \end{code} \begin{code} -checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -checkTH _ _ = return () -- OK -#else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "requires GHC with interpreter support"), - ptext (sLit "Perhaps you are using a stage-1 compiler?"), - nest 2 (ppr e)]) -#endif -\end{code} - -\begin{code} checkThLocalName :: Name -> ThLevel -> RnM () #ifndef GHCI /* GHCI and TH is off */ -------------------------------------- diff --git a/compiler/rename/RnSplice.lhs-boot b/compiler/rename/RnSplice.lhs-boot index 2e9990f207..128f5ef6d3 100644 --- a/compiler/rename/RnSplice.lhs-boot +++ b/compiler/rename/RnSplice.lhs-boot @@ -7,8 +7,6 @@ import RdrName import Name import NameSet -import Outputable - rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) @@ -16,6 +14,4 @@ rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) - -checkTH :: Outputable a => a -> String -> RnM () \end{code} diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 0db92e8f90..0052393bb4 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -21,9 +21,7 @@ module RnTypes ( extractRdrKindSigVars, extractDataDefnKindVars, filterInScope ) where -#ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) -#endif /* GHCI */ import {-# SOURCE #-} RnSplice( rnSpliceType ) import DynFlags @@ -261,16 +259,12 @@ rnHsTyKi isType doc (HsDocTy ty haddock_doc) ; haddock_doc' <- rnLHsDoc haddock_doc ; return (HsDocTy ty' haddock_doc', fvs) } -#ifndef GHCI -rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) -#else rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT( isType ) do { ty <- runQuasiQuoteType qq -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) ; rnHsType doc (HsParTy ty) } -#endif rnHsTyKi isType _ (HsCoreTy ty) = ASSERT( isType ) diff --git a/compiler/typecheck/TcAnnotations.lhs b/compiler/typecheck/TcAnnotations.lhs index 1d495c0eec..4f4ab60f24 100644 --- a/compiler/typecheck/TcAnnotations.lhs +++ b/compiler/typecheck/TcAnnotations.lhs @@ -7,6 +7,8 @@ \begin{code} module TcAnnotations ( tcAnnotations ) where +import {-# SOURCE #-} TcSplice ( runAnnotation ) + import HsSyn import Annotations import Name @@ -14,12 +16,9 @@ import TcRnMonad import SrcLoc import Outputable -#ifdef GHCI import Module import TcExpr -import {-# SOURCE #-} TcSplice ( runAnnotation ) import FastString -#endif \end{code} \begin{code} @@ -27,15 +26,11 @@ tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation] tcAnnotations = mapM tcAnnotation tcAnnotation :: LAnnDecl Name -> TcM Annotation -#ifndef GHCI --- TODO: modify lexer so ANN pragmas are parsed as comments in a stage1 compiler, so developers don't see this error -tcAnnotation (L _ (HsAnnotation _ expr)) = pprPanic "Cant do annotations without GHCi" (ppr expr) -#else tcAnnotation ann@(L loc (HsAnnotation provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule let target = annProvenanceToTarget mod provenance - + -- Run that annotation and construct the full Annotation data structure setSrcSpan loc $ addErrCtxt (annCtxt ann) $ addExprErrCtxt expr $ runAnnotation target expr @@ -47,5 +42,4 @@ annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod annCtxt :: OutputableBndr id => LAnnDecl id -> SDoc annCtxt ann = hang (ptext (sLit "In the annotation:")) 2 (ppr ann) -#endif \end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d03a43b747..d047afc6fa 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,9 +12,9 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, #include "HsVersions.h" -#ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) -import qualified DsMeta +#ifdef GHCI +import DsMeta( liftStringName, liftName ) #endif import HsSyn @@ -797,7 +797,6 @@ tcExpr (PArrSeq _ _) _ %************************************************************************ \begin{code} -#ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsRnBracketOut brack ps) res_ty = tcBracket brack ps res_ty @@ -805,7 +804,6 @@ tcExpr e@(HsBracketOut _ _) _ = pprPanic "Should never see HsBracketOut in type checker" (ppr e) tcExpr e@(HsQuasiQuoteE _) _ = pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) -#endif /* GHCI */ \end{code} @@ -1339,6 +1337,10 @@ checkCrossStageLifting id _ (Brack _ _ ps_var lie_var) ; writeMutVar ps_var (PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id)) : ps) ; return () } + +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) #endif /* GHCI */ \end{code} @@ -1616,10 +1618,4 @@ missingFields con fields <+> pprWithCommas ppr fields -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) - -#ifdef GHCI -polySpliceErr :: Id -> SDoc -polySpliceErr id - = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id) -#endif \end{code} diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b7cd841081..853cee906f 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -41,10 +41,6 @@ module TcHsType ( #include "HsVersions.h" -#ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( tcSpliceType ) -#endif - import HsSyn import TcRnMonad import TcEvidence( HsWrapper ) @@ -509,31 +505,19 @@ tc_hs_type (HsCoreTy ty) exp_kind ; return ty } -#ifdef GHCI /* Only if bootstrapped */ --- This looks highly suspect to me --- It will really only be fixed properly when we do the TH --- reorganisation so that type splices happen in the renamer -tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind - = do { s <- getStage - ; traceTc "tc_hs_type: splice" (ppr sp $$ ppr s) - ; (ty, kind) <- tcSpliceType sp fvs - ; checkExpectedKind hs_ty kind exp_kind --- -- See Note [Kind of a type splice] - ; return ty } -#else -tc_hs_type ty@(HsSpliceTy {}) _exp_kind +-- This should never happen; type splices are expanded by the renamer +tc_hs_type ty@(HsSpliceTy {}) _exp_kind = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -#endif -tc_hs_type (HsWrapTy {}) _exp_kind +tc_hs_type (HsWrapTy {}) _exp_kind = panic "tc_hs_type HsWrapTy" -- We kind checked something twice -tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind +tc_hs_type hs_ty@(HsTyLit (HsNumTy n)) exp_kind = do { checkExpectedKind hs_ty typeNatKind exp_kind ; checkWiredInTyCon typeNatKindCon ; return (mkNumLitTy n) } -tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind +tc_hs_type hs_ty@(HsTyLit (HsStrTy s)) exp_kind = do { checkExpectedKind hs_ty typeSymbolKind exp_kind ; checkWiredInTyCon typeSymbolKindCon ; return (mkStrLitTy s) } diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 6168dc216d..1b66b948f1 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -828,6 +828,20 @@ ifErrsM bale_out normal failIfErrsM :: TcRn () -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) + +checkTH :: Outputable a => a -> String -> TcRn () +#ifdef GHCI +checkTH _ _ = return () -- OK +#else +checkTH e what = failTH e what -- Raise an error in a stage-1 compiler +#endif + +failTH :: Outputable a => a -> String -> TcRn x +failTH e what -- Raise an error in a stage-1 compiler + = failWithTc (vcat [ text what + <+> ptext (sLit "requires GHC with interpreter support") + , ptext (sLit "Perhaps you are using a stage-1 compiler?") + , nest 2 (ppr e)]) \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index fde2d7bc99..5b41fdbe35 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -9,26 +9,40 @@ TcSplice: Template Haskell splices \begin{code} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, - tcTopSpliceExpr, - lookupThName_maybe, - runQuasiQuoteExpr, runQuasiQuotePat, - runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - runQuasi, runMetaE, runMetaP, runMetaT, runMetaD ) where +module TcSplice( + -- These functions are defined in stage1 and stage2 + -- The raise civilised errors in stage1 + tcSpliceExpr, tcSpliceDecls, tcBracket, + runQuasiQuoteExpr, runQuasiQuotePat, + runQuasiQuoteDecl, runQuasiQuoteType, + runAnnotation, + +#ifdef GHCI + -- These ones are defined only in stage2, and are + -- called only in stage2 (ie GHCI is on) + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, +#endif + ) where #include "HsVersions.h" +import HsSyn +import Annotations +import Name +import TcRnMonad +import RdrName +import TcType + +#ifdef GHCI import HscMain -- These imports are the reason that TcSplice -- is very high up the module hierarchy import HscTypes -import HsSyn import Convert import RnExpr import RnEnv -import RdrName import RnTypes import TcExpr import TcHsSyn @@ -36,7 +50,7 @@ import TcSimplify import TcUnify import Type import Kind -import TcType +import NameSet import TcEnv import TcMType import TcHsType @@ -45,16 +59,12 @@ import TypeRep import FamInst import FamInstEnv import InstEnv -import Name import NameEnv -import NameSet import PrelNames import OccName import Hooks import Var import Module -import Annotations -import TcRnMonad import LoadIface import Class import Inst @@ -64,13 +74,11 @@ import DataCon import TcEvidence( TcEvBinds(..) ) import Id import IdInfo -import DsMeta import DsExpr import DsMonad hiding (Splice) import Serialized import ErrUtils import SrcLoc -import Outputable import Util import Data.List ( mapAccumL ) import Unique @@ -80,25 +88,60 @@ import Maybes( MaybeErr(..) ) import DynFlags import Panic import FastString +import Outputable import Control.Monad ( when ) +import DsMeta import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH -#ifdef GHCI -- Because GHC.Desugar might not be in the base library of the bootstrapping compiler import GHC.Desugar ( AnnotationWrapper(..) ) import qualified Data.Map as Map import Data.Dynamic ( fromDynamic, toDyn ) import Data.Typeable ( typeOf ) -#endif - import Data.Data (Data) import GHC.Exts ( unsafeCoerce# ) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection{Main interface + stubs for the non-GHCI case +%* * +%************************************************************************ + +\begin{code} +tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId) +tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName] +tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) + -- None of these functions add constraints to the LIE + +runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) +runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) +runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] + +runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation + +#ifndef GHCI +tcBracket x _ _ = failTH x "Template Haskell bracket" +tcSpliceExpr e _ = failTH e "Template Haskell splice" +tcSpliceDecls x = failTH x "Template Haskell declaration splice" + +runQuasiQuoteExpr q = failTH q "quasiquote" +runQuasiQuotePat q = failTH q "pattern quasiquote" +runQuasiQuoteType q = failTH q "type quasiquote" +runQuasiQuoteDecl q = failTH q "declaration quasiquote" +runAnnotation _ q = failTH q "annotation" + +#else + -- The whole of the rest of the file is the else-branch (ie stage2 only) \end{code} + Note [How top-level splices are handled] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Top-level splices (those not inside a [| .. |] quotation bracket) are handled @@ -288,46 +331,6 @@ The predicate we use is TcEnv.thTopLevelId. %************************************************************************ %* * -\subsection{Main interface + stubs for the non-GHCI case -%* * -%************************************************************************ - -\begin{code} -tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId) -tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName] -tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) - -- None of these functions add constraints to the LIE - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) - -runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) -runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) -runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) -runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation - -#ifndef GHCI -tcBracket x _ _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) -tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) -tcSplicePat e = pprPanic "Cant do tcSplicePat without GHCi" (ppr e) -tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) -tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) - -lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) - -runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) -runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) -runQuasiQuoteType q = pprPanic "Cant do runQuasiQuoteType without GHCi" (ppr q) -runQuasiQuoteDecl q = pprPanic "Cant do runQuasiQuoteDecl without GHCi" (ppr q) -runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q) -#else -\end{code} - -%************************************************************************ -%* * \subsection{Quoting an expression} %* * %************************************************************************ @@ -526,6 +529,7 @@ tcTopSplice expr res_ty %************************************************************************ \begin{code} +tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) tcSplicePat splice@(HsSplice True _ _) _ = pprPanic "tcSplicePat: encountered typed pattern splice" (ppr splice) @@ -623,6 +627,7 @@ We don't want the type checker to see these bogus unbound variables. Very like splicing an expression, but we don't yet share code. \begin{code} +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) tcSpliceType splice@(HsSplice True _ _) _ = pprPanic "tcSpliceType: encountered a typed type splice" (ppr splice) @@ -1151,7 +1156,6 @@ illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped bracke illegalUntypedSplice :: SDoc illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets") -#endif /* GHCI */ \end{code} @@ -1261,6 +1265,7 @@ lookupThName th_name = do Nothing -> failWithTc (notInScope th_name) Just name -> return name +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) -- Pick the first that works @@ -1729,3 +1734,6 @@ will appear in TH syntax like this data T a = forall b. (a ~ [b]) => MkT1 b | (a ~ Int) => MkT2 +\begin{code} +#endif /* GHCI */ +\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 9bacd1f707..07ba144958 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -5,19 +5,19 @@ import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, import HsExpr ( PendingSplice ) import Id ( Id ) import Name ( Name ) -import NameSet ( FreeVars ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcType, TcKind ) +import TcType ( TcRhoType ) import Annotations ( Annotation, CoreAnnTarget ) + +#ifdef GHCI import qualified Language.Haskell.TH as TH +#endif tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) - tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName] tcBracket :: HsBracket Name @@ -27,17 +27,19 @@ tcBracket :: HsBracket Name tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) - runQuasiQuoteDecl :: HsQuasiQuote RdrName -> TcM [LHsDecl RdrName] runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation -runQuasi :: TH.Q a -> TcM a runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) runMetaP :: LHsExpr Id -> TcM (LPat RdrName) runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] + +#ifdef GHCI +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +runQuasi :: TH.Q a -> TcM a +#endif \end{code} |