#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
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,
\begin{code}
-module Convert( convertToHsExpr, convertToHsDecls ) where
+module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
#include "HsVersions.h"
(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)
-- 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)
\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
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
[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
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 _ _ _)))
%************************************************************************
\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 |]
#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 )
| HsKindSig (LHsType name) -- (ty :: kind)
Kind -- A type with a kind signature
+ | HsSpliceTy (HsSplice name)
+
data HsExplicitForAll = Explicit | Implicit
-----------------------
\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
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]
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("=>")
-- 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
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 $
import Bag ( emptyBag )
import Panic
-import GLAEXTS
import CStrings ( CLabelString )
import FastString
import Maybes ( orElse )
import Outputable
+import GLAEXTS
}
{-
| '_' { 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)) }
: 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 }
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)
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
\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
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(..) )
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) ->
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) ->
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
-> 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)
module RnSource (
rnSrcDecls, addTcgDUs,
rnTyClDecls, checkModDeprec,
- rnBindGroups, rnBindGroupsAndThen
+ rnBindGroups, rnBindGroupsAndThen, rnSplice
) where
#include "HsVersions.h"
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 )
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
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
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) ->
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) ->
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"),
\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}
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 ->
-- Kind checking
kcHsTyVars, kcHsSigType, kcHsLiftedSigType,
- kcCheckHsType, kcHsContext,
+ kcCheckHsType, kcHsContext, kcHsType,
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcTyVarBndrs, dsHsType,
= 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)
-- 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 )
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}
\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)
%************************************************************************
\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 ->
%************************************************************************
%* *
+ 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)
+
+ ; kcHsType hs_ty3 }
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Splicing an expression}
%* *
%************************************************************************
\begin{code}
-- Always at top level
tcSpliceDecls expr
- = tcMetaTy decTyConName `thenM` \ meta_dec_ty ->
- tcMetaTy qTyConName `thenM` \ meta_q_ty ->
- let
- list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
- in
- tcTopSpliceExpr expr list_q `thenM` \ zonked_q_expr ->
-
- -- Run the expression
- traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
- runMetaD zonked_q_expr `thenM` \ simple_expr ->
- -- simple_expr :: [TH.Dec]
- -- decls :: [RdrNameHsDecl]
- handleErrors (convertToHsDecls simple_expr) `thenM` \ decls ->
- traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
- showSplice "declarations"
- zonked_q_expr (vcat (map ppr decls)) `thenM_`
- returnM decls
+ = do { meta_dec_ty <- tcMetaTy decTyConName
+ ; meta_q_ty <- tcMetaTy qTyConName
+ ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
+ ; zonked_q_expr <- tcTopSpliceExpr expr list_q
+
+ -- Run the expression
+ ; traceTc (text "About to run" <+> ppr zonked_q_expr)
+ ; simple_expr <- runMetaD zonked_q_expr
+
+ -- simple_expr :: [TH.Dec]
+ -- decls :: [RdrNameHsDecl]
+ ; decls <- handleErrors (convertToHsDecls simple_expr)
+ ; traceTc (text "Got result" <+> vcat (map ppr decls))
+ ; showSplice "declarations"
+ zonked_q_expr (vcat (map ppr decls))
+ ; returnM decls }
where handleErrors :: [Either a Message] -> TcM [a]
handleErrors [] = return []
-> TcM TH.Exp -- Of type Exp
runMetaE e = runMeta e
-runMetaD :: LHsExpr Id -- Of type Q [Dec]
+runMetaT :: LHsExpr Id -- Of type (Q Type)
+ -> TcM TH.Type -- Of type Type
+runMetaT e = runMeta e
+
+runMetaD :: LHsExpr Id -- Of type Q [Dec]
-> TcM [TH.Dec] -- Of type [Dec]
runMetaD e = runMeta e
\begin{code}
reify :: TH.Name -> TcM TH.Info
-reify (TH.Name occ (TH.NameG th_ns mod))
- = do { name <- lookupOrig (mkModuleName (TH.modString mod))
- (OccName.mkOccName ghc_ns (TH.occString occ))
+reify th_name
+ = do { name <- lookupThName th_name
; thing <- tcLookup name
+ -- ToDo: this tcLookup could fail, which would give a
+ -- rather unhelpful error message
; reifyThing thing
}
+
+lookupThName :: TH.Name -> TcM Name
+lookupThName (TH.Name occ (TH.NameG th_ns mod))
+ = lookupOrig (mkModuleName (TH.modString mod))
+ (OccName.mkOccName ghc_ns (TH.occString occ))
where
ghc_ns = case th_ns of
TH.DataName -> dataName
TH.TcClsName -> tcClsName
TH.VarName -> varName
+lookupThName th_name@(TH.Name occ TH.NameS)
+ = do { let rdr_name = mkRdrUnqual (OccName.mkOccFS ns occ_fs)
+ ; rdr_env <- getLocalRdrEnv
+ ; case lookupLocalRdrEnv rdr_env rdr_name of
+ Just name -> return name
+ Nothing -> do
+ { mb_name <- lookupSrcOcc_maybe rdr_name
+ ; case mb_name of
+ Just name -> return name ;
+ Nothing -> failWithTc (notInScope th_name)
+ }}
+ where
+ ns | isLexCon occ_fs = OccName.dataName
+ | otherwise = OccName.varName
+ occ_fs = mkFastString (TH.occString occ)
+
+lookupThName (TH.Name occ (TH.NameU uniq))
+ = return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc)
+ where
+ occ_fs = mkFastString (TH.occString occ)
+ bogus_ns = OccName.varName -- Not yet recorded in the TH name
+ -- but only the unique matters
+
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
+
+notInScope :: TH.Name -> SDoc
+notInScope th_name = quotes (text (show (TH.pprName th_name))) <+>
+ ptext SLIT("is not in scope at a reify")
+ -- Ugh! Rather an indirect way to display the name
+
------------------------------
reifyThing :: TcTyThing -> TcM TH.Info
-- The only reason this is monadic is for error reporting,
projects / ghc-hetmet.git / commitdiff