From: simonpj Date: Tue, 16 Dec 2003 16:25:16 +0000 (+0000) Subject: [project @ 2003-12-16 16:24:55 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~186 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cb2be98ac73ffcc2e2cd631de403e83569a12b4d;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 4bcc2c9..0350843 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index e312028..288885d 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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, diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index b26b168..9fd060a 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -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) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index efedcd6..0db816c 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -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)] diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 index 1987cc4..30d90a0 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 @@ -1,6 +1,7 @@ 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 diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index f4915a2..dd10217 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -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 |] diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index da941ef..c659297 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -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 $ diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4dec2de..02a723a 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -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 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 01df302..ef047ba 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index fb32abe..59d0dd1 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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) -> diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 5e30960..5d31672 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -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 diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 index 4c0ac50..e4d5e3b 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-6 +++ b/ghc/compiler/rename/RnSource.hi-boot-6 @@ -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) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index c70e7f6..43e644e 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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 diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index e41c775..c5c541b 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -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"), diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 60226de..151a62a 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 8968e49..5e3c774 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -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 -> diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 7d6e53c..757097c 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6 index 6c0a291..8fbf843 100644 --- a/ghc/compiler/typecheck/TcSplice.hi-boot-6 +++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6 @@ -1,10 +1,12 @@ 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) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 001b913..36a7220 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -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 -> @@ -239,6 +241,71 @@ tcTopSpliceExpr expr meta_ty %************************************************************************ %* * + 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} %* * %************************************************************************ @@ -246,23 +313,22 @@ tcTopSpliceExpr expr meta_ty \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 [] @@ -283,7 +349,11 @@ runMetaE :: LHsExpr Id -- Of type (Q Exp) -> 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 @@ -366,18 +436,55 @@ illegalSplice level \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,