| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
+ | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) }
+ | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice
+ (L1 $ HsVar (mkUnqual varName
+ (getTH_ID_SPLICE $1)))) } -- $x
-- Generics
| INTEGER { L1 (HsNumTy (getINTEGER $1)) }
import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
#endif /* GHCI */
-import RnSource ( rnSrcDecls, rnSplice, checkTH )
+import RnSource ( rnSrcDecls )
import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
-import RnTypes ( rnHsTypeFVs,
+import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat
import DynFlags ( DynFlag(..) )
\begin{code}
module RnSource (
- rnSrcDecls, addTcgDUs,
- rnTyClDecls,
- rnSplice, checkTH
+ rnSrcDecls, addTcgDUs, rnTyClDecls
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
- globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import Name ( Name, nameOccName )
import NameSet
import NameEnv
-import OccName
import Outputable
import Bag
import FastString
ptext (sLit "(You can put a context on each contructor, though.)")]
\end{code}
+
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
\end{code}
-%*********************************************************
-%* *
- Splices
-%* *
-%*********************************************************
-
-Note [Splices]
-~~~~~~~~~~~~~~
-Consider
- f = ...
- h = ...$(thing "f")...
-
-The splice can expand into literally anything, so when we do dependency
-analysis we must assume that it might mention 'f'. So we simply treat
-all locally-defined names as mentioned by any splice. This is terribly
-brutal, but I don't see what else to do. For example, it'll mean
-that every locally-defined thing will appear to be used, so no unused-binding
-warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
-and that will crash the type checker because 'f' isn't in scope.
-
-Currently, I'm not treating a splice as also mentioning every import,
-which is a bit inconsistent -- but there are a lot of them. We might
-thereby get some bogus unused-import warnings, but we won't crash the
-type checker. Not very satisfactory really.
-
-\begin{code}
-rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
-rnSplice (HsSplice n expr)
- = do { checkTH expr "splice"
- ; loc <- getSrcSpanM
- ; [n'] <- newLocalsRn [L loc n]
- ; (expr', fvs) <- rnLExpr expr
-
- -- Ugh! See Note [Splices] above
- ; lcl_rdr <- getLocalRdrEnv
- ; gbl_rdr <- getGlobalRdrEnv
- ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
- isLocalGRE gre]
- lcl_names = mkNameSet (occEnvElts lcl_rdr)
-
- ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
-
-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 "illegal in a stage-1 compiler"),
- nest 2 (ppr e)])
-#endif
-\end{code}
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
- checkPrecMatch, checkSectionPrec
+ checkPrecMatch, checkSectionPrec,
+
+ -- Splice related stuff
+ rnSplice, checkTH
) where
+import {-# SOURCE #-} RnExpr( rnLExpr )
+
import DynFlags
import HsSyn
import RdrHsSyn ( extractHsRhoRdrTyVars )
pred' <- rnPred doc pred
return (HsPredTy pred')
-rnHsType _ (HsSpliceTy _) =
- failWith (ptext (sLit "Type splices are not yet implemented"))
+rnHsType _ (HsSpliceTy sp)
+ = do { (sp', _fvs) <- rnSplice sp -- ToDo: deal with fvs
+ ; return (HsSpliceTy sp') }
rnHsType doc (HsDocTy ty haddock_doc) = do
ty' <- rnLHsType doc ty
forall_head _other = False
opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
\end{code}
+
+%*********************************************************
+%* *
+ Splices
+%* *
+%*********************************************************
+
+Note [Splices]
+~~~~~~~~~~~~~~
+Consider
+ f = ...
+ h = ...$(thing "f")...
+
+The splice can expand into literally anything, so when we do dependency
+analysis we must assume that it might mention 'f'. So we simply treat
+all locally-defined names as mentioned by any splice. This is terribly
+brutal, but I don't see what else to do. For example, it'll mean
+that every locally-defined thing will appear to be used, so no unused-binding
+warnings. But if we miss the dependency, then we might typecheck 'h' before 'f',
+and that will crash the type checker because 'f' isn't in scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them. We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker. Not very satisfactory really.
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+ = do { checkTH expr "splice"
+ ; loc <- getSrcSpanM
+ ; [n'] <- newLocalsRn [L loc n]
+ ; (expr', fvs) <- rnLExpr expr
+
+ -- Ugh! See Note [Splices] above
+ ; lcl_rdr <- getLocalRdrEnv
+ ; gbl_rdr <- getGlobalRdrEnv
+ ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
+ isLocalGRE gre]
+ lcl_names = mkNameSet (occEnvElts lcl_rdr)
+
+ ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
+
+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 "illegal in a stage-1 compiler"),
+ nest 2 (ppr e)])
+#endif
+\end{code}
\begin{code}
module TcHsType (
- tcHsSigType, tcHsDeriv,
+ tcHsSigType, tcHsSigTypeNC, tcHsDeriv,
tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
#include "HsVersions.h"
+#ifdef GHCI /* Only if bootstrapped */
+import {-# SOURCE #-} TcSplice( kcSpliceType )
+#endif
+
import HsSyn
import RnHsSyn
import TcRnMonad
%************************************************************************
\begin{code}
-tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
+tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
-- Do kind checking, and hoist for-alls to the top
-- NB: it's important that the foralls that come from the top-level
-- HsForAllTy in hs_ty occur *first* in the returned type.
-- See Note [Scoped] with TcSigInfo
tcHsSigType ctxt hs_ty
= addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
- do { kinded_ty <- kcTypeType hs_ty
+ tcHsSigTypeNC ctxt hs_ty
+
+tcHsSigTypeNC ctxt hs_ty
+ = do { (kinded_ty, _kind) <- kc_lhs_type hs_ty
+ -- The kind is checked by checkValidType, and isn't necessarily
+ -- of kind * in a Template Haskell quote eg [t| Maybe |]
; ty <- tcHsKindedType kinded_ty
; checkValidType ctxt ty
; return ty }
(ty', kind) <- kc_lhs_type ty
return (HsBangTy b ty', kind)
-kc_hs_type ty@(HsSpliceTy _)
- = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#ifdef GHCI /* Only if bootstrapped */
+kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+#else
+kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#endif
-- remove the doc nodes here, no need to worry about the location since
-- its the same for a doc node and it's child type node
ForSigCtxt _ -> gen_rank 1
SpecInstCtxt -> gen_rank 1
+ ThBrackCtxt -> gen_rank 1
actual_kind = typeKind ty
kind_ok = case ctxt of
TySynCtxt _ -> True -- Any kind will do
+ ThBrackCtxt -> True -- Any kind will do
ResSigCtxt -> isSubOpenTypeKind actual_kind
ExprSigCtxt -> isSubOpenTypeKind actual_kind
GenPatCtxt -> isLiftedTypeKind actual_kind
ubx_tup = case ctxt of
TySynCtxt _ | unboxed -> UT_Ok
ExprSigCtxt | unboxed -> UT_Ok
+ ThBrackCtxt | unboxed -> UT_Ok
_ -> UT_NotOk
-- Check that the thing has kind Type, and is lifted if necessary
check_arg_type rank ty
= do { impred <- doptM Opt_ImpredicativeTypes
- ; let rank' = if impred then ArbitraryRank -- Arg of tycon can have arby rank, regardless
- else case rank of -- Predictive => must be monotype
- MustBeMonoType -> MustBeMonoType
- _ -> TyConArgMonoType
+ ; let rank' = case rank of -- Predictive => must be monotype
+ MustBeMonoType -> MustBeMonoType -- Monotype, regardless
+ _other | impred -> ArbitraryRank
+ | otherwise -> TyConArgMonoType
-- Make sure that MustBeMonoType is propagated,
-- so that we don't suggest -XImpredicativeTypes in
-- (Ord (forall a.a)) => a -> a
+ -- and so that if it Must be a monotype, we check that it is!
; check_type rank' UT_NotOk ty
; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
+module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
; return (ConE "Data.Maybe.Just" s7) }
\begin{code}
-tcBracket brack res_ty = do
- level <- getStage
- case bracketOK level of {
- Nothing -> failWithTc (illegalBracket level) ;
- Just next_level -> do
+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 {
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
- recordThUse
- pending_splices <- newMutVar []
- lie_var <- getLIEVar
+ recordThUse
+ ; pending_splices <- newMutVar []
+ ; lie_var <- getLIEVar
- (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
- (getLIE (tc_bracket next_level brack))
- tcSimplifyBracket lie
+ ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
+ (getLIE (tc_bracket next_level brack))
+ ; tcSimplifyBracket lie
-- Make the expected type have the right shape
- boxyUnify meta_ty res_ty
+ ; boxyUnify meta_ty res_ty
-- Return the original expression, not the type-decorated one
- pendings <- readMutVar pending_splices
- return (noLoc (HsBracketOut brack pendings))
- }
+ ; pendings <- readMutVar pending_splices
+ ; return (noLoc (HsBracketOut brack pendings)) }}}
tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
tc_bracket _ (ExpBr expr)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; tcMonoExpr expr any_ty
+ ; tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is Expr (= Q Exp)
tc_bracket _ (TypBr typ)
- = do { tcHsSigType ExprSigCtxt typ
+ = do { tcHsSigTypeNC ThBrackCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
\begin{code}
module TcSplice where
import HsSyn ( HsSplice, HsBracket, HsQuasiQuote,
- HsExpr, LHsExpr, LPat, LHsDecl )
+ HsExpr, HsType, LHsExpr, LPat, LHsDecl )
import Name ( Name )
import RdrName ( RdrName )
import TcRnTypes( TcM, TcId )
-import TcType ( BoxyRhoType )
+import TcType ( BoxyRhoType, TcKind )
import Annotations ( Annotation, CoreAnnTarget )
import qualified Language.Haskell.TH as TH
-> BoxyRhoType
-> TcM (HsExpr TcId)
+kcSpliceType :: HsSplice Name
+ -> TcM (HsType Name, TcKind)
+
tcBracket :: HsBracket Name
-> BoxyRhoType
-> TcM (LHsExpr TcId)
| ForSigCtxt Name -- Foreign inport or export signature
| DefaultDeclCtxt -- Types in a default declaration
| SpecInstCtxt -- SPECIALISE instance pragma
+ | ThBrackCtxt -- Template Haskell type brackets [t| ... |]
-- Notes re TySynCtxt
-- We allow type synonyms that aren't types; e.g. type List = []
pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition")
+pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]")
pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature")
pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature")
pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature")
projects / ghc-hetmet.git / commitdiff