Commit cb2be98a authored by simonpj's avatar simonpj

[project @ 2003-12-16 16:24:55 by simonpj]

--------------------
	Towards type splices
	--------------------

Starts the move to supporting type splices, by making
HsExpr.HsSplice a separate type of its own, and adding
HsSpliceTy constructor to HsType.
parent 626b9cd2
......@@ -546,7 +546,7 @@ Here is where we desugar the Template Haskell brackets and escapes
#ifdef GHCI /* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e)
dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
#endif
-- Arrow notation extension
......
......@@ -489,15 +489,15 @@ repE (ArithSeqIn aseq) =
repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _) =
panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSplice n e) = do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
other -> pprPanic "HsSplice" (ppr n) }
repE e =
pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _))
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
other -> pprPanic "HsSplice" (ppr n) }
repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
......
......@@ -6,7 +6,7 @@ This module converts Template Haskell syntax into HsSyn
\begin{code}
module Convert( convertToHsExpr, convertToHsDecls ) where
module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
#include "HsVersions.h"
......@@ -313,6 +313,8 @@ cvt_pred ty = case split_ty_app ty of
(VarT tv, tys) -> noLoc (HsClassP (tName tv) (map cvtType tys))
other -> cvtPanic "Malformed predicate" (text (show (TH.pprType ty)))
convertToHsType = cvtType
cvtType :: TH.Type -> LHsType RdrName
cvtType ty = trans (root ty [])
where root (AppT a b) zs = root a (cvtType b : zs)
......@@ -372,30 +374,29 @@ loc0 = srcLocSpan generatedSrcLoc
-- variable names
vName :: TH.Name -> RdrName
vName = mk_name OccName.varName
vName = thRdrName OccName.varName
-- Constructor function names; this is Haskell source, hence srcDataName
cName :: TH.Name -> RdrName
cName = mk_name OccName.srcDataName
cName = thRdrName OccName.srcDataName
-- Type variable names
tName :: TH.Name -> RdrName
tName = mk_name OccName.tvName
tName = thRdrName OccName.tvName
-- Type Constructor names
tconName = mk_name OccName.tcName
mk_name :: OccName.NameSpace -> TH.Name -> RdrName
tconName = thRdrName OccName.tcName
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
-- This turns a Name into a RdrName
-- The last case is slightly interesting. It constructs a
-- unique name from the unique in the TH thingy, so that the renamer
-- won't mess about. I hope. (Another possiblity would be to generate
-- "x_77" etc, but that could conceivably clash.)
mk_name ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
mk_name ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
mk_name ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
mk_uniq :: Int# -> Unique
mk_uniq u = mkUniqueGrimily (I# u)
......
......@@ -262,10 +262,10 @@ eqHsSig _other1 _other2 = False
\end{code}
\begin{code}
instance (Outputable name) => Outputable (Sig name) where
instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: Outputable name => Sig name -> SDoc
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (Sig var ty)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
......
module HsExpr where
data HsExpr i
data HsSplice i
data Match a
data GRHSs a
......@@ -10,6 +11,9 @@ type LMatch a = SrcLoc.Located (Match a)
pprExpr :: (Outputable.OutputableBndr i) =>
HsExpr.HsExpr i -> Outputable.SDoc
pprSplice :: (Outputable.OutputableBndr i) =>
HsExpr.HsSplice i -> Outputable.SDoc
pprPatBind :: (Outputable.OutputableBndr i) =>
HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc
......
......@@ -151,9 +151,7 @@ data HsExpr id
[PendingSplice] -- renamed expression, plus *typechecked* splices
-- to be pasted back in by the desugarer
| HsSplice id (LHsExpr id) -- $z or $(f 4)
-- The id is just a unique name to
-- identify this splice point
| HsSpliceE (HsSplice id)
-----------------------------------------------------------
-- Arrow notation extension
......@@ -403,8 +401,8 @@ ppr_expr (DictApp expr dnames)
ppr_expr (HsType id) = ppr id
ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b) = ppr b
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
......@@ -766,6 +764,17 @@ pprComp brack stmts
%************************************************************************
\begin{code}
data HsSplice id = HsSplice -- $z or $(f 4)
id -- The id is just a unique name to
(LHsExpr id) -- identify this splice point
instance OutputableBndr id => Outputable (HsSplice id) where
ppr = pprSplice
pprSplice :: OutputableBndr id => HsSplice id -> SDoc
pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e
data HsBracket id = ExpBr (LHsExpr id) -- [| expr |]
| PatBr (LPat id) -- [p| pat |]
| DecBr (HsGroup id) -- [d| decls |]
......
......@@ -28,6 +28,8 @@ module HsTypes (
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
import TcType ( Type, Kind, liftedTypeKind, eqKind )
import Type ( {- instance Outputable Kind -}, pprParendKind, pprKind )
import Name ( Name, mkInternalName )
......@@ -133,6 +135,8 @@ data HsType name
| HsKindSig (LHsType name) -- (ty :: kind)
Kind -- A type with a kind signature
| HsSpliceTy (HsSplice name)
data HsExplicitForAll = Explicit | Implicit
-----------------------
......@@ -198,7 +202,7 @@ replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k
\begin{code}
splitHsInstDeclTy
:: Outputable name
:: OutputableBndr name
=> HsType name
-> ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
-- Split up an instance decl type, returning the pieces
......@@ -246,14 +250,14 @@ NB: these types get printed into interface files, so
don't change the printing format lightly
\begin{code}
instance (Outputable name) => Outputable (HsType name) where
instance (OutputableBndr name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance (Outputable name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar name) = ppr name
ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
instance Outputable name => Outputable (HsPred name) where
instance OutputableBndr name => Outputable (HsPred name) where
ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys)
ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty]
......@@ -270,7 +274,7 @@ pprHsForAll exp tvs cxt
is_explicit = case exp of {Explicit -> True; Implicit -> False}
forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot
pprHsContext :: (Outputable name) => HsContext name -> SDoc
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext [] = empty
pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>")
......@@ -295,7 +299,7 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
-- printing works more-or-less as for Types
pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty pREC_TOP (prepare sty ty)
pprParendHsType ty = ppr_mono_ty pREC_CON ty
......@@ -321,6 +325,7 @@ ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred)
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only
ppr_mono_ty ctxt_prec (HsSpliceTy s) = pprSplice s
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec pREC_CON $
......
......@@ -37,11 +37,11 @@ import OrdList
import Bag ( emptyBag )
import Panic
import GLAEXTS
import CStrings ( CLabelString )
import FastString
import Maybes ( orElse )
import Outputable
import GLAEXTS
}
{-
......@@ -1051,10 +1051,11 @@ aexp2 :: { LHsExpr RdrName }
| '_' { L1 EWildPat }
-- MetaHaskell Extension
| TH_ID_SPLICE { L1 $ mkHsSplice
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
(getTH_ID_SPLICE $1))) } -- $x
| '$(' exp ')' { LL $ mkHsSplice $2 } -- $( exp )
(getTH_ID_SPLICE $1)))) } -- $x
| '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) }
......@@ -1076,8 +1077,12 @@ acmd :: { LHsCmdTop RdrName }
: aexp2 { L1 $ HsCmdTop $1 [] placeHolderType undefined }
cvtopbody :: { [LHsDecl RdrName] }
: '{' cvtopdecls '}' { $2 }
| vocurly cvtopdecls close { $2 }
: '{' cvtopdecls0 '}' { $2 }
| vocurly cvtopdecls0 close { $2 }
cvtopdecls0 :: { [LHsDecl RdrName] }
: {- empty -} { [] }
| cvtopdecls { $1 }
texps :: { [LHsExpr RdrName] }
: texps ',' exp { $3 : $1 }
......
......@@ -117,6 +117,7 @@ extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc
extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsParTy ty) acc = extract_lty ty acc
extract_ty (HsNumTy num) acc = acc
extract_ty (HsSpliceTy _) acc = acc -- Type splices mention no type variables
extract_ty (HsKindSig ty k) acc = extract_lty ty acc
extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
extract_ty (HsForAllTy exp tvs cx ty)
......@@ -285,9 +286,10 @@ hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
hsIfaceType (HsParTy t) = hsIfaceLType t
hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
hsIfaceType (HsKindSig t _) = hsIfaceLType t
hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
-----------
hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
......
......@@ -12,12 +12,12 @@ free variables.
\begin{code}
module RnExpr (
rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
checkPrecMatch
checkPrecMatch, checkTH
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups )
import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice )
-- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
-- RnBinds imports RnExpr.rnMatch, etc
......@@ -29,7 +29,7 @@ import TcRnMonad
import RnEnv
import OccName ( plusOccEnv )
import RnNames ( importsFromLocalDecls )
import RnTypes ( rnHsTypeFVs, rnLPat, litFVs, rnOverLit, rnPatsAndThen,
import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
dupFieldErr, precParseErr, sectionPrecErr, patSigErr,
checkTupSize )
import CmdLineOpts ( DynFlag(..) )
......@@ -177,8 +177,8 @@ rnExpr (HsIPVar v)
returnM (HsIPVar name, emptyFVs)
rnExpr (HsLit lit)
= litFVs lit `thenM` \ fvs ->
returnM (HsLit lit, fvs)
= rnLit lit `thenM_`
returnM (HsLit lit, emptyFVs)
rnExpr (HsOverLit lit)
= rnOverLit lit `thenM` \ (lit', fvs) ->
......@@ -227,12 +227,9 @@ rnExpr e@(HsBracket br_body)
rnBracket br_body `thenM` \ (body', fvs_e) ->
returnM (HsBracket body', fvs_e)
rnExpr e@(HsSplice n splice)
= checkTH e "splice" `thenM_`
getSrcSpanM `thenM` \ loc ->
newLocalsRn [L loc n] `thenM` \ [n'] ->
rnLExpr splice `thenM` \ (splice', fvs_e) ->
returnM (HsSplice n' splice', fvs_e)
rnExpr e@(HsSpliceE splice)
= rnSplice splice `thenM` \ (splice', fvs) ->
returnM (HsSpliceE splice', fvs)
rnExpr section@(SectionL expr op)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
......
......@@ -56,6 +56,7 @@ extractHsTyNames ty
get (HsParTy ty) = getl ty
get (HsNumTy n) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables
get (HsKindSig ty k) = getl ty
get (HsForAllTy _ tvs
ctxt ty) = (extractHsCtxtTyNames ctxt
......
......@@ -9,5 +9,8 @@ rnBindGroups :: [HsBinds.HsBindGroup RdrName.RdrName]
-> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ;
rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
-> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name)
-> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) ;
rnSplice :: HsExpr.HsSplice RdrName.RdrName
-> TcRnTypes.RnM (HsExpr.HsSplice Name.Name, NameSet.FreeVars)
......@@ -7,7 +7,7 @@
module RnSource (
rnSrcDecls, addTcgDUs,
rnTyClDecls, checkModDeprec,
rnBindGroups, rnBindGroupsAndThen
rnBindGroups, rnBindGroupsAndThen, rnSplice
) where
#include "HsVersions.h"
......@@ -16,7 +16,7 @@ import HsSyn
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
import RdrHsSyn ( extractGenericPatTyVars )
import RnHsSyn
import RnExpr ( rnLExpr )
import RnExpr ( rnLExpr, checkTH )
import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds,
rnBindsAndThen, renameSigs, checkSigs )
......@@ -677,3 +677,19 @@ rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
\end{code}
%*********************************************************
%* *
Splices
%* *
%*********************************************************
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
= checkTH expr "splice" `thenM_`
getSrcSpanM `thenM` \ loc ->
newLocalsRn [L loc n] `thenM` \ [n'] ->
rnLExpr expr `thenM` \ (expr', fvs) ->
returnM (HsSplice n' expr', fvs)
\end{code}
\ No newline at end of file
......@@ -7,7 +7,7 @@
module RnTypes ( rnHsType, rnLHsType, rnContext,
rnHsSigType, rnHsTypeFVs,
rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part
rnOverLit, litFVs, -- of any mutual recursion
rnLit, rnOverLit, -- of any mutual recursion
precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
) where
......@@ -338,12 +338,9 @@ rnPat (SigPatIn pat ty)
where
doc = text "In a pattern type-signature"
rnPat (LitPat s@(HsString _))
= returnM (LitPat s, unitFV eqStringName)
rnPat (LitPat lit)
= litFVs lit `thenM` \ fvs ->
returnM (LitPat lit, fvs)
= rnLit lit `thenM_`
returnM (LitPat lit, emptyFVs)
rnPat (NPatIn lit mb_neg)
= rnOverLit lit `thenM` \ (lit', fvs1) ->
......@@ -484,22 +481,9 @@ that the types and classes they involve
are made available.
\begin{code}
litFVs (HsChar c)
= checkErr (inCharRange c) (bogusCharError c) `thenM_`
returnM (unitFV charTyCon_name)
litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon))
litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name])
litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon))
litFVs (HsInt i) = returnM (unitFV (getName intTyCon))
litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon))
litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon))
litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon))
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit)
-- HsInteger and HsRat only appear
-- in post-typechecker translations
bogusCharError c
= ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
rnLit :: HsLit -> RnM ()
rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
rnLit other = returnM ()
rnOverLit (HsIntegral i _)
= lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) ->
......@@ -557,6 +541,9 @@ forAllWarn doc ty (L loc tyvar)
doc
)
bogusCharError c
= ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
precParseErr op1 op2
= hang (ptext SLIT("precedence parsing error"))
4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
......
......@@ -574,11 +574,9 @@ tc_expr (PArrSeqIn _) _
\begin{code}
#ifdef GHCI /* Only if bootstrapped */
-- Rename excludes these cases otherwise
tc_expr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
tc_expr (HsBracket brack) res_ty = do
e <- tcBracket brack res_ty
return (unLoc e)
tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
tc_expr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty
; return (unLoc e) }
#endif /* GHCI */
\end{code}
......
......@@ -407,8 +407,8 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
returnM (n,e')
zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
returnM (HsSplice n e)
zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
returnM (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
......
......@@ -10,7 +10,7 @@ module TcHsType (
-- Kind checking
kcHsTyVars, kcHsSigType, kcHsLiftedSigType,
kcCheckHsType, kcHsContext,
kcCheckHsType, kcHsContext, kcHsType,
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcTyVarBndrs, dsHsType,
......@@ -248,6 +248,9 @@ kc_hs_type (HsParTy ty)
= kcHsType ty `thenM` \ (ty', kind) ->
returnM (HsParTy ty', kind)
-- kcHsType (HsSpliceTy s)
-- = kcSpliceType s)
kc_hs_type (HsTyVar name)
= kcTyVar name `thenM` \ kind ->
returnM (HsTyVar name, kind)
......
module TcSplice where
tcSpliceExpr :: Name.Name
-> HsExpr.LHsExpr Name.Name
tcSpliceExpr :: HsExpr.HsSplice Name.Name
-> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.HsExpr Var.Id)
kcSpliceType :: HsExpr.HsSplice Name.Name
-> TcRnTypes.TcM (HsType.HsType Name.Name, TcType.TcKind)
tcBracket :: HsExpr.HsBracket Name.Name
-> TcUnify.Expected TcType.TcType
-> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id)
......
......@@ -14,23 +14,27 @@ import TcRnDriver ( tcTopSrcDecls )
-- is very high up the module hierarchy
import qualified Language.Haskell.TH.THSyntax as TH
import qualified Language.Haskell.TH.THLib as TH
-- THSyntax gives access to internal functions and data types
import HscTypes ( HscEnv(..) )
import HsSyn ( HsBracket(..), HsExpr(..), LHsExpr, LHsDecl )
import Convert ( convertToHsExpr, convertToHsDecls )
import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
HsType, LHsType )
import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType )
import RnExpr ( rnLExpr )
import RnEnv ( lookupFixityRn )
import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe )
import RdrName ( RdrName, mkRdrUnqual, lookupLocalRdrEnv )
import RnTypes ( rnLHsType )
import TcExpr ( tcCheckRho, tcMonoExpr )
import TcHsSyn ( mkHsLet, zonkTopLExpr )
import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
import TcUnify ( Expected, zapExpectedTo, zapExpectedType )
import TcType ( TcType, openTypeKind, mkAppTy, tcSplitSigmaTy )
import TcType ( TcType, TcKind, openTypeKind, mkAppTy, tcSplitSigmaTy )
import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup )
import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
import TcHsType ( tcHsSigType )
import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar )
import TcHsType ( tcHsSigType, kcHsType )
import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName )
import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName )
import OccName
import Var ( Id, TyVar, idType )
import RdrName ( RdrName )
......@@ -47,17 +51,17 @@ import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
import ErrUtils ( Message )
import SrcLoc ( noLoc, unLoc )
import SrcLoc ( noLoc, unLoc, getLoc, noSrcLoc )
import Outputable
import Unique ( Unique, Uniquable(..), getKey )
import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
import IOEnv ( IOEnv )
import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
import Module ( moduleUserString )
import Panic ( showException )
import FastString ( LitString )
import FastString ( LitString, mkFastString )
import FastTypes ( iBox )
import GHC.Base ( unsafeCoerce#, Int(..) ) -- Should have a better home in the module hierarchy
import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy
import Monad ( liftM )
\end{code}
......@@ -70,11 +74,8 @@ import Monad ( liftM )
\begin{code}
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: Name
-> LHsExpr Name
-> Expected TcType
-> TcM (HsExpr Id)
tcSpliceExpr :: HsSplice Name -> Expected TcType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
#ifndef GHCI
tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
......@@ -150,8 +151,9 @@ tc_bracket (DecBr decls)
%************************************************************************
\begin{code}
tcSpliceExpr name expr res_ty
= getStage `thenM` \ level ->
tcSpliceExpr (HsSplice name expr) res_ty
= addSrcSpan (getLoc expr) $
getStage `thenM` \ level ->
case spliceOK level of {
Nothing -> failWithTc (illegalSplice level) ;
Just next_level ->
......@@ -237,6 +239,71 @@ tcTopSpliceExpr expr meta_ty
\end{code}
%************************************************************************
%* *
Splicing a type
%* *
%************************************************************************
Very like splicing an expression, but we don't yet share code.
\begin{code}
kcSpliceType (HsSplice name hs_expr)
= addSrcSpan (getLoc hs_expr) $ do
{ level <- getStage
; case spliceOK level of {
Nothing -> failWithTc (illegalSplice level) ;
Just next_level -> do
{ case level of {
Comp -> do { (t,k) <- kcTopSpliceType hs_expr
; return (unLoc t, k) } ;
Brack _ ps_var lie_var -> do
{ -- A splice inside brackets
; meta_ty <- tcMetaTy typeQTyConName
; expr' <- setStage (Splice next_level) $
setLIEVar lie_var $
tcCheckRho hs_expr meta_ty
-- Write the pending splice into the bucket
; ps <- readMutVar ps_var
; writeMutVar ps_var ((name,expr') : ps)
-- e.g. [| Int -> $(h 4) |]
-- Here (h 4) :: Q Type
-- but $(h 4) :: forall a.a i.e. any kind
; kind <- newKindVar
; returnM (panic "kcSpliceType", kind) -- The returned type is ignored
}}}}}
kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
kcTopSpliceType expr
= do { meta_ty <- tcMetaTy typeQTyConName
-- Typecheck the expression
; zonked_q_expr <- tcTopSpliceExpr expr meta_ty
-- Run the expression
; traceTc (text "About to run" <+> ppr zonked_q_expr)
; simple_ty <- runMetaT zonked_q_expr
; let -- simple_ty :: TH.Type
hs_ty2 :: LHsType RdrName
hs_ty2 = convertToHsType simple_ty
; traceTc (text "Got result" <+> ppr hs_ty2)
; showSplice "type" zonked_q_expr (ppr hs_ty2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
; let doc = ptext SLIT("In the spliced type") <+> ppr hs_ty2
; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)