From: simonpj@microsoft.com Date: Fri, 18 Jan 2008 14:55:03 +0000 (+0000) Subject: Add quasi-quotation, courtesy of Geoffrey Mainland X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f3399c446c7507d46d6cc550aa2fe7027dbc1b5b Add quasi-quotation, courtesy of Geoffrey Mainland This patch adds quasi-quotation, as described in "Nice to be Quoted: Quasiquoting for Haskell" (Geoffrey Mainland, Haskell Workshop 2007) Implemented by Geoffrey and polished by Simon. Overview ~~~~~~~~ The syntax for quasiquotation is very similar to the existing Template haskell syntax: [$q| stuff |] where 'q' is the "quoter". This syntax differs from the paper, by using a '$' rather than ':', to avoid clashing with parallel array comprehensions. The "quoter" is a value of type Language.Haskell.TH.Quote.QuasiQuoter, which contains two functions for quoting expressions and patterns, respectively. quote = Language.Haskell.TH.Quote.QuasiQuoter quoteExp quotePat quoteExp :: String -> Language.Haskell.TH.ExpQ quotePat :: String -> Language.Haskell.TH.PatQ TEXT is passed unmodified to the quoter. The context of the quasiquotation statement determines which of the two quoters is called: if the quasiquotation occurs in an expression context, quoteExp is called, and if it occurs in a pattern context, quotePat is called. The result of running the quoter on its arguments is spliced into the program using Template Haskell's existing mechanisms for splicing in code. Note that although Template Haskell does not support pattern brackets, with this patch binding occurrences of variables in patterns are supported. Quoters must also obey the same stage restrictions as Template Haskell; in particular, in this example quote may not be defined in the module where it is used as a quasiquoter, but must be imported from another module. Points to notice ~~~~~~~~~~~~~~~~ * The whole thing is enabled with the flag -XQuasiQuotes * There is an accompanying patch to the template-haskell library. This involves one interface change: currentModule :: Q String is replaced by location :: Q Loc where Loc is a data type defined in TH.Syntax thus: data Loc = Loc { loc_filename :: String , loc_package :: String , loc_module :: String , loc_start :: CharPos , loc_end :: CharPos } type CharPos = (Int, Int) -- Line and character position So you get a lot more info from 'location' than from 'currentModule'. The location you get is the location of the splice. This works in Template Haskell too of course, and lets a TH program generate much better error messages. * There's also a new module in the template-haskell package called Language.Haskell.TH.Quote, which contains support code for the quasi-quoting feature. * Quasi-quote splices are run *in the renamer* because they can build *patterns* and hence the renamer needs to see the output of running the splice. This involved a bit of rejigging in the renamer, especially concerning the reporting of duplicate or shadowed names. (In fact I found and removed a few calls to checkDupNames in RnSource that are redundant, becuase top-level duplicate decls are handled in RnNames.) --- diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 558ed16..a307a00 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -29,7 +29,7 @@ module RdrName ( -- LocalRdrEnv LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, - lookupLocalRdrEnv, elemLocalRdrEnv, + lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, -- GlobalRdrEnv GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, @@ -276,6 +276,9 @@ lookupLocalRdrEnv env (Exact name) = Just name lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ lookupLocalRdrEnv env other = Nothing +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc env occ = lookupOccEnv env occ + elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name env | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env @@ -354,7 +357,7 @@ pprGlobalRdrEnv env \begin{code} lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of Nothing -> [] Just gres -> gres diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index fda74e0..44c51f3 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -186,7 +186,12 @@ data SrcSpan | UnhelpfulSpan FastString -- Just a general indication -- also used to indicate an empty span +#ifdef DEBUG + deriving (Eq, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token +#else deriving Eq +#endif -- We want to order SrcSpans first by the start point, then by the end point. instance Ord SrcSpan where diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 9859167..42e96bf 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -22,8 +22,9 @@ module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, decQTyConName, typeQTyConName, - decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName + liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, + quoteExpName, quotePatName ) where #include "HsVersions.h" @@ -1425,11 +1426,15 @@ templateHaskellNames = [ decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] + fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + + -- Quasiquoting + quoteExpName, quotePatName] thSyn :: Module thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax") thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib") +qqLib = mkTHModule FSLIT("Language.Haskell.TH.Quote") mkTHModule m = mkModule thPackageId (mkModuleNameFS m) @@ -1437,6 +1442,7 @@ libFun = mk_known_key_name OccName.varName thLib libTc = mk_known_key_name OccName.tcName thLib thFun = mk_known_key_name OccName.varName thSyn thTc = mk_known_key_name OccName.tcName thSyn +qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName = thTc FSLIT("Q") qTyConKey @@ -1603,6 +1609,10 @@ fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey patQTyConName = libTc FSLIT("PatQ") patQTyConKey fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey +-- quasiquoting +quoteExpName = qqFun FSLIT("quoteExp") quoteExpKey +quotePatName = qqFun FSLIT("quotePat") quotePatKey + -- TyConUniques available: 100-129 -- Check in PrelNames if you want to change this @@ -1769,3 +1779,7 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307 -- data FunDep = ... funDepIdKey = mkPreludeMiscIdUnique 320 +-- quasiquoting +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322 + diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index d97bfd9..96b5fc1 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -13,7 +13,7 @@ This module converts Template Haskell syntax into HsSyn -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module Convert( convertToHsExpr, convertToHsDecls, +module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, thRdrName ) where #include "HsVersions.h" @@ -58,6 +58,13 @@ convertToHsExpr loc e <+> text (show e))) Right res -> Right res +convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat loc e + = case initCvt loc (cvtPat e) of + Left msg -> Left (msg $$ (ptext SLIT("When converting TH pattern") + <+> text (show e))) + Right res -> Right res + convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) convertToHsType loc t = initCvt loc (cvtType t) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 7683fae..68dcda8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -203,6 +203,9 @@ data HsExpr id | HsSpliceE (HsSplice id) + | HsQuasiQuoteE (HsQuasiQuote id) + -- See Note [Quasi-quote overview] in TcSplice + ----------------------------------------------------------- -- Arrow notation extension @@ -438,6 +441,10 @@ ppr_expr (HsSpliceE s) = pprSplice s ppr_expr (HsBracket b) = pprHsBracket b ppr_expr (HsBracketOut e []) = ppr e ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps +ppr_expr (HsQuasiQuoteE (HsQuasiQuote name quoter _ quote)) + = char '$' <> brackets (ppr name) <> + ptext SLIT("[:") <> ppr quoter <> ptext SLIT("|") <> + ppr quote <> ptext SLIT("|]") ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd] diff --git a/compiler/hsSyn/HsPat.hi-boot-6 b/compiler/hsSyn/HsPat.hi-boot-6 index 593caf2..dfa7777 100644 --- a/compiler/hsSyn/HsPat.hi-boot-6 +++ b/compiler/hsSyn/HsPat.hi-boot-6 @@ -1,4 +1,6 @@ module HsPat where +data HsQuasiQuote i = HsQuasiQuote i i SrcSpan FastString + data Pat i type LPat i = SrcLoc.Located (Pat i) diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 87f4717..266cff2 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -19,6 +19,8 @@ module HsPat ( HsConPatDetails, hsConPatArgs, HsRecFields(..), HsRecField(..), hsRecFields, + HsQuasiQuote(..), + mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI, isBangHsBind, @@ -46,6 +48,7 @@ import TyCon import Outputable import Type import SrcLoc +import FastString \end{code} @@ -113,6 +116,10 @@ data Pat id -- (= the argument type of the view function) -- for hsPatType. + ------------ Quasiquoted patterns --------------- + -- See Note [Quasi-quote overview] in TcSplice + | QuasiQuotePat (HsQuasiQuote id) + ------------ Literal and n+k patterns --------------- | LitPat HsLit -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. @@ -200,6 +207,14 @@ hsRecFields :: HsRecFields id arg -> [id] hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds) \end{code} +\begin{code} +data HsQuasiQuote id = HsQuasiQuote + id + id + SrcSpan + FastString +\end{code} + %************************************************************************ %* * @@ -247,6 +262,10 @@ pprPat (LitPat s) = ppr s pprPat (NPat l Nothing _) = ppr l pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] +pprPat (QuasiQuotePat (HsQuasiQuote name quoter _ quote)) + = char '$' <> brackets (ppr name) <> + ptext SLIT("[:") <> ppr quoter <> ptext SLIT("|") <> + ppr quote <> ptext SLIT("|]") pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") pprPat (CoPat co pat _) = parens (pprHsWrapper (ppr pat) co) pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index d5b685c..f5d250e 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -1,6 +1,9 @@ \begin{code} module HsPat where -import SrcLoc( Located ) +import SrcLoc( Located, SrcSpan ) +import FastString ( FastString ) + +data HsQuasiQuote i = HsQuasiQuote i i SrcSpan FastString data Pat i type LPat i = Located (Pat i) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 5d106f1..05352d0 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -161,6 +161,12 @@ unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) -- A name (uniquified later) to -- identify the splice +mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote + +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + mkHsString s = HsString (mkFastString s) ------------- @@ -417,6 +423,7 @@ collectl (L l pat) bndrs go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs + go (QuasiQuotePat _) = bndrs go (TypePat ty) = bndrs go (CoPat _ pat ty) = collectl (noLoc pat) bndrs \end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index df4052c..97cbfc8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -197,6 +197,7 @@ data DynFlag | Opt_PArr -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax | Opt_TemplateHaskell + | Opt_QuasiQuotes | Opt_ImplicitParams | Opt_Generics | Opt_ImplicitPrelude @@ -1319,6 +1320,7 @@ xFlags = [ ( "Arrows", Opt_Arrows ), ( "PArr", Opt_PArr ), ( "TemplateHaskell", Opt_TemplateHaskell ), + ( "QuasiQuotes", Opt_QuasiQuotes ), ( "Generics", Opt_Generics ), -- On by default: ( "ImplicitPrelude", Opt_ImplicitPrelude ), diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 521c2d1..84ee57e 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -308,6 +308,9 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } "|]" / { ifExtension thEnabled } { token ITcloseQuote } \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } "$(" / { ifExtension thEnabled } { token ITparenEscape } + + "[$" @varid "|" / { ifExtension qqEnabled } + { lex_quasiquote_tok } } <0> { @@ -542,6 +545,7 @@ data Token | ITparenEscape -- $( | ITvarQuote -- ' | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc @@ -1318,6 +1322,42 @@ getCharOrFail = do Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len = do + let quoter = reverse $ takeWhile (/= '$') + $ reverse $ lexemeToString buf (len - 1) + quoteStart <- getSrcLoc + quote <- lex_quasiquote "" + end <- getSrcLoc + return (L (mkSrcSpan (srcSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + mkFastString (reverse quote), + mkSrcSpan quoteStart end))) + +lex_quasiquote :: String -> P String +lex_quasiquote s = do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error + + Just ('\\',i) + | Just ('|',i) <- next -> do + setInput i; lex_quasiquote ('|' : s) + | Just (']',i) <- next -> do + setInput i; lex_quasiquote (']' : s) + where next = alexGetChar' i + + Just ('|',i) + | Just (']',i) <- next -> do + setInput i; return s + where next = alexGetChar' i + + Just (c, i) -> do + setInput i; lex_quasiquote (c : s) + +-- ----------------------------------------------------------------------------- -- Warnings warn :: DynFlag -> SDoc -> Action @@ -1520,6 +1560,7 @@ unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc unboxedTuplesBit = 15 -- (# and #) standaloneDerivingBit = 16 -- standalone instance deriving declarations transformComprehensionsBit = 17 +qqBit = 18 -- enable quasiquoting genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool always _ = True @@ -1540,6 +1581,7 @@ unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit +qqEnabled flags = testBit flags qqBit -- PState for parsing options pragmas -- @@ -1586,6 +1628,7 @@ mkPState buf loc flags = .|. parrBit `setBitIf` dopt Opt_PArr flags .|. arrowsBit `setBitIf` dopt Opt_Arrows flags .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 1783ce3..57832c3 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -337,6 +337,7 @@ TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) TH_VAR_QUOTE { L _ ITvarQuote } -- 'x TH_TY_QUOTE { L _ ITtyQuote } -- ''T +TH_QUASIQUOTE { L _ (ITquasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } @@ -1368,6 +1369,11 @@ aexp2 :: { LHsExpr RdrName } (getTH_ID_SPLICE $1)))) } -- $x | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) + | TH_QUASIQUOTE { let { loc = getLoc $1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkUnqual varName quoter + } + in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) } | 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)) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6e77dee..be51624 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -702,6 +702,7 @@ checkAPat loc e = case e of RecordCon c _ (HsRecFields fs dd) -> mapM checkPatField fs >>= \fs -> return (ConPatIn c (RecCon (HsRecFields fs dd))) + HsQuasiQuoteE q -> return (QuasiQuotePat q) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 0dbed29..7e38efe 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -44,7 +44,7 @@ import RnEnv ( lookupLocatedBndrRn, bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, bindLocatedLocalsRn, - checkDupNames, checkShadowing + checkDupAndShadowedRdrNames ) import DynFlags ( DynFlag(..) ) import HscTypes (FixItem(..)) @@ -282,8 +282,7 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do -- Do error checking: we need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more. - checkDupNames doc boundNames - checkShadowing doc boundNames + checkDupAndShadowedRdrNames doc boundNames -- (Note that we don't want to do this at the top level, since -- sorting out duplicates and shadowing there happens elsewhere. diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 66177a9..d924ab1 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -31,7 +31,9 @@ module RnEnv ( bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, - checkDupNames, checkShadowing, mapFvRn, mapFvRnCPS, + checkDupRdrNames, checkDupNames, checkShadowedNames, + checkDupAndShadowedRdrNames, + mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, @@ -45,27 +47,17 @@ import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, LHsTyVarBndr, LHsType, Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, - isQual_maybe, - mkRdrUnqual, setRdrNameSpace, rdrNameOcc, - pprGlobalRdrEnv, lookupGRE_RdrName, - isExact_maybe, isSrcRdrName, - Parent(..), - GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, - isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, - importSpecLoc, importSpecModule - ) +import RdrName import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, isExternalName ) + nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) import NameSet import NameEnv import UniqFM import DataCon ( dataConFieldLabels ) -import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, +import OccName ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused, occNameFS ) import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) @@ -356,7 +348,7 @@ lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) getLookupOccRn :: RnM (Name -> Maybe Name) getLookupOccRn = getLocalRdrEnv `thenM` \ local_env -> - return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName) + return (lookupLocalRdrOcc local_env . nameOccName) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -746,16 +738,21 @@ newLocalsRn rdr_names_w_loc -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName mkInternalName uniq (rdrNameOcc rdr_name) loc +--------------------- +checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM () +checkDupAndShadowedRdrNames doc loc_rdr_names + = do { checkDupRdrNames doc loc_rdr_names + ; envs <- getRdrEnvs + ; checkShadowedNames doc envs + [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] } + +--------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = -- Check for duplicate names - checkDupNames doc_str rdr_names_w_loc `thenM_` - - -- Warn about shadowing - checkShadowing doc_str rdr_names_w_loc `thenM_` + = checkDupAndShadowedRdrNames doc_str rdr_names_w_loc `thenM_` -- Make fresh Names and extend the environment newLocalsRn rdr_names_w_loc `thenM` \names -> @@ -841,31 +838,39 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- +checkDupRdrNames :: SDoc + -> [Located RdrName] + -> RnM () +checkDupRdrNames doc_str rdr_names_w_loc + = -- Check for duplicated names in a binding group + mappM_ (dupNamesErr getLoc doc_str) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + checkDupNames :: SDoc - -> [Located RdrName] + -> [Name] -> RnM () -checkDupNames doc_str rdr_names_w_loc +checkDupNames doc_str names = -- Check for duplicated names in a binding group - mappM_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr nameSrcSpan doc_str) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names ------------------------------------- -checkShadowing doc_str loc_rdr_names - = traceRn (text "shadow" <+> ppr loc_rdr_names) `thenM_` - getLocalRdrEnv `thenM` \ local_env -> - getGlobalRdrEnv `thenM` \ global_env -> - let - check_shadow (L loc rdr_name) - | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)] +checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () +checkShadowedNames doc_str (global_env,local_env) loc_rdr_names + = ifOptM Opt_WarnNameShadowing $ + do { traceRn (text "shadow" <+> ppr loc_rdr_names) + ; mappM_ check_shadow loc_rdr_names } + where + check_shadow (loc, occ) + | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr loc] | not (null gres) = complain (map pprNameProvenance gres) | otherwise = return () where - complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str rdr_name pp_locs) - mb_local = lookupLocalRdrEnv local_env rdr_name - gres = lookupGRE_RdrName rdr_name global_env - in - ifOptM Opt_WarnNameShadowing (mappM_ check_shadow loc_rdr_names) + complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs) + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGlobalRdrEnv global_env occ \end{code} @@ -983,8 +988,8 @@ addNameClashErrRn rdr_name names msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn doc rdr_name shadowed_locs - = sep [ptext SLIT("This binding for") <+> quotes (ppr rdr_name) +shadowedNameWarn doc occ shadowed_locs + = sep [ptext SLIT("This binding for") <+> quotes (ppr occ) <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs, nest 2 (vcat shadowed_locs)] $$ doc @@ -1002,14 +1007,13 @@ badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr :: SDoc -> [Located RdrName] -> RnM () -dupNamesErr descriptor located_names +dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM () +dupNamesErr get_loc descriptor names = addErrAt big_loc $ - vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr (head names)), locations, descriptor] where - L _ name1 = head located_names - locs = map getLoc located_names + locs = map get_loc names big_loc = foldr1 combineSrcSpans locs one_line = isOneLineSpan big_loc locations | one_line = empty diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index a41a305..176fdb4 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,6 +23,10 @@ module RnExpr ( #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) +#endif /* GHCI */ + import RnSource ( rnSrcDecls, rnSplice, checkTH ) import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, rnMatchGroup, makeMiniFixityEnv) @@ -33,7 +37,7 @@ import HscTypes ( availNames ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) -import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, +import RnPat (rnQuasiQuote, rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, localRecNameMaker, rnLit, rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize) import RdrName ( mkRdrUnqual ) @@ -175,6 +179,16 @@ rnExpr e@(HsSpliceE splice) = rnSplice splice `thenM` \ (splice', fvs) -> returnM (HsSpliceE splice', fvs) +#ifndef GHCI +rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) +#else +rnExpr e@(HsQuasiQuoteE qq) + = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) -> + runQuasiQuoteExpr qq' `thenM` \ (L _ expr') -> + rnExpr expr' `thenM` \ (expr'', fvs_expr) -> + returnM (expr'', fvs_qq `plusFV` fvs_expr) +#endif /* GHCI */ + rnExpr section@(SectionL expr op) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> rnLExpr op `thenM` \ (op', fvs_op) -> @@ -958,7 +972,7 @@ rn_rec_stmts_lhs fix_env stmts = -- First do error checking: we need to check for dups here because we -- don't bind all of the variables from the Stmt at once -- with bindLocatedLocals. - checkDupNames doc boundNames + checkDupRdrNames doc boundNames mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls) diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 8c75caa..49f6f1d 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -30,6 +30,9 @@ module RnPat (-- main entry points -- Literals rnLit, rnOverLit, + -- Quasiquotation + rnQuasiQuote, + -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr ) where @@ -37,6 +40,9 @@ module RnPat (-- main entry points -- ENH: thin imports to only what is necessary for patterns import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuotePat ) +#endif /* GHCI */ #include "HsVersions.h" @@ -57,12 +63,15 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, eqClassName, integralClassName, geName, eqName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName, fromStringName ) + ratioDataConName, fromRationalName, fromStringName, mkUnboundName ) import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan ) +import Name ( Name, nameOccName, nameModule_maybe, getOccName, nameSrcSpan ) +import OccName ( occEnvElts ) import NameSet import UniqFM -import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName ) +import RdrName ( RdrName, GlobalRdrElt(..), Provenance(..), + extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, + mkRdrUnqual, nameRdrName, gre_name, globalRdrEnvElts, isLocalGRE ) import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) @@ -161,21 +170,23 @@ rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages -> RnM (a, FreeVars) rnPatsAndThen_LocalRightwards ctxt pats thing_inside - = do { -- Check for duplicated and shadowed names - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - let rdr_names_w_loc = collectLocatedPatsBinders pats - ; checkDupNames doc_pat rdr_names_w_loc - ; checkShadowing doc_pat rdr_names_w_loc + = do { envs_before <- getRdrEnvs -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - rnLPatsAndThen matchNameMaker pats $ - thing_inside } + rnLPatsAndThen matchNameMaker pats $ \ pats' -> + do { -- Check for duplicated and shadowed names + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + ; let names = collectPatsBinders pats' + ; checkDupNames doc_pat names + ; checkShadowedNames doc_pat envs_before + [(nameSrcSpan name, nameOccName name) | name <- names] + ; thing_inside pats' } } where doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt @@ -288,6 +299,16 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = lcont (ViewPat expr' pat' ty) ; return (res, fvs_res `plusFV` fv_expr) } +#ifndef GHCI + pat@(QuasiQuotePat _) -> pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) +#else + QuasiQuotePat qq -> do + (qq', _) <- rnQuasiQuote qq + pat' <- runQuasiQuotePat qq' + rnLPatAndThen var pat' $ \ (L _ pat'') -> + lcont pat'' +#endif /* GHCI */ + ConPatIn con stuff -> -- rnConPatAndThen takes care of reconstructing the pattern rnConPatAndThen var con stuff cont @@ -543,6 +564,26 @@ rnOverLit (HsIsString s _ _) returnM (HsIsString s from_string_name placeHolderType, fvs) \end{code} +%************************************************************************ +%* * +\subsubsection{Quasiquotation} +%* * +%************************************************************************ + +See Note [Quasi-quote overview] in TcSplice. + +\begin{code} +rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars) +rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote) + = do { loc <- getSrcSpanM + ; [n'] <- newLocalsRn [L loc n] + ; quoter' <- (lookupOccRn quoter) + -- If 'quoter' is not in scope, proceed no further + -- Otherwise lookupOcc adds an error messsage and returns + -- an "unubound name", which makes the subsequent attempt to + -- run the quote fail + ; return (HsQuasiQuote n' quoter' quoteSpan quote, unitFV quoter') } +\end{code} %************************************************************************ %* * diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 7573f5e..8e2094d 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -34,7 +34,7 @@ import RnEnv ( lookupLocalDataTcNames, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, checkDupNames, mapFvRn, lookupGreLocalRn, + bindLocalNames, checkDupRdrNames, mapFvRn, lookupGreLocalRn, ) import RnNames (importsFromLocalDecls, extendRdrEnvRn) import HscTypes (GenAvailInfo(..)) @@ -360,16 +360,6 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> - -- Rename the associated types - -- The typechecker (not the renamer) checks that all - -- the declarations are for the right class - let - at_doc = text "In the associated types of an instance declaration" - at_names = map (head . tyClDeclNames . unLoc) ats - in - checkDupNames at_doc at_names `thenM_` - rnATInsts ats `thenM` \ (ats', at_fvs) -> - -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class @@ -378,13 +368,34 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) meth_names = collectHsBindLocatedBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupNames meth_doc meth_names `thenM_` + checkDupRdrNames meth_doc meth_names `thenM_` + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration + extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too rnMethodBinds cls (\n->[]) -- No scoped tyvars [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> + -- Rename the associated types + -- The typechecker (not the renamer) checks that all + -- the declarations are for the right class + let + at_doc = text "In the associated types of an instance declaration" + at_names = map (head . tyClDeclNames . unLoc) ats + in + checkDupRdrNames at_doc at_names `thenM_` + -- See notes with checkDupRdrNames for methods, above + + rnATInsts ats `thenM` \ (ats', at_fvs) -> + -- Rename the prags and signatures. -- Note that the type variables are not in scope here, -- so that instance Eq a => Eq (T a) where @@ -602,8 +613,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe ; (derivs', deriv_fvs) <- rn_derivs derivs - ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendRdrEnvRn ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, @@ -629,8 +641,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- do not scope over the constructor signatures -- data T a where { T1 :: forall b. b-> b } ; (derivs', deriv_fvs) <- rn_derivs derivs - ; checkDupNames data_doc con_names ; condecls' <- rnConDecls (unLoc tycon') condecls + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendRdrEnvRn ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = Nothing, tcdKindSig = sig, @@ -694,14 +707,13 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; sigs' <- renameSigs okClsDclSig sigs ; return (tyvars', context', fds', ats', ats_fvs, sigs') } - -- Check for duplicates among the associated types - ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats] - ; checkDupNames at_doc at_rdr_names_w_locs + -- No need to check for duplicate associated type decls + -- since that is done by RnNames.extendRdrEnvRn -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] - ; checkDupNames sig_doc sig_rdr_names_w_locs + ; checkDupRdrNames sig_doc sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -721,7 +733,9 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, not (unLoc tv `elemLocalRdrEnv` name_env) ] - ; checkDupNames meth_doc meth_rdr_names_w_locs + -- No need to check for duplicate method signatures + -- since that is done by RnNames.extendRdrEnvRn + -- and the methods are already in scope ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } @@ -820,8 +834,9 @@ rnConDeclDetails doc (InfixCon ty1 ty2) returnM (InfixCon new_ty1 new_ty2) rnConDeclDetails doc (RecCon fields) - = do { checkDupNames doc (map cd_fld_name fields) - ; new_fields <- mappM (rnField doc) fields + = do { new_fields <- mappM (rnField doc) fields + -- No need to check for duplicate fields + -- since that is done by RnNames.extendRdrEnvRn ; return (RecCon new_fields) } rnField doc (ConDeclField name ty haddock_doc) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 99d0c54..ebbb738 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -588,6 +588,8 @@ tcExpr (PArrSeq _ _) _ tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = do { e <- tcBracket brack res_ty ; return (unLoc e) } +tcExpr e@(HsQuasiQuoteE _) res_ty = + pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e) #endif /* GHCI */ \end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index defe6fb..5815688 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -386,6 +386,9 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside ; return (LazyPat pat', [], res) } +tc_pat _ p@(QuasiQuotePat _) _ _ + = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p) + tc_pat pstate (WildPat _) pat_ty thing_inside = do { pat_ty' <- unBoxWildCardType pat_ty -- Make sure it's filled in with monotypes ; res <- thing_inside pstate diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 68db3a2..ed1dce6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -397,6 +397,9 @@ tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index feaf9f9..c1ab87d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -318,8 +318,8 @@ data TcLclEnv -- Changes as we move inside an expression tcl_ctxt :: ErrCtxt, -- Error context tcl_errs :: TcRef Messages, -- Place to accumulate errors - tcl_th_ctxt :: ThStage, -- Template Haskell context - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context tcl_rdr :: LocalRdrEnv, -- Local name envt -- Maintained during renaming, of course, but also during diff --git a/compiler/typecheck/TcSplice.hi-boot-6 b/compiler/typecheck/TcSplice.hi-boot-6 index aa73980..c33439e 100644 --- a/compiler/typecheck/TcSplice.hi-boot-6 +++ b/compiler/typecheck/TcSplice.hi-boot-6 @@ -12,4 +12,6 @@ tcBracket :: HsExpr.HsBracket Name.Name -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) tcSpliceDecls :: HsExpr.LHsExpr Name.Name - -> TcRnTypes.TcM [HsDecls.LHsDecl RdrName.RdrName] + +runQuasiQuoteExpr :: HsQuasiQuote Name.Name -> TcM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 9ec400d..50bbc3c 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -13,7 +13,8 @@ TcSplice: Template Haskell splices -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where +module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, + runQuasiQuoteExpr, runQuasiQuotePat ) where #include "HsVersions.h" @@ -165,9 +166,15 @@ tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) -- None of these functions add constraints to the LIE +runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) + #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) + +runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q) +runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q) #else \end{code} @@ -358,6 +365,80 @@ tcTopSpliceExpr expr meta_ty %************************************************************************ %* * + Quasi-quoting +%* * +%************************************************************************ + +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GHC "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). + +Briefly, one writes + [:p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose +type should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be +defined in another module, because we are going to run it here. It's +a bit like a TH splice: + $(p "stuff") + +However, you can do this in patterns as well as terms. Becuase of this, +the splice is run by the *renamer* rather than the type checker. + +\begin{code} +runQuasiQuote :: Outputable hs_syn + => HsQuasiQuote Name -- Contains term of type QuasiQuoter, and the String + -> Name -- Of type QuasiQuoter -> String -> Q th_syn + -> String -- Documentation string only + -> Name -- Name of th_syn type + -> (SrcSpan -> th_syn -> Either Message hs_syn) + -> TcM hs_syn +runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert + = do { -- Check that the quoter is not locally defined, otherwise the TH + -- machinery will not be able to run the quasiquote. + ; this_mod <- getModule + ; let is_local = case nameModule_maybe quoter of + Just mod | mod == this_mod -> True + | otherwise -> False + Nothing -> True + ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local) + ; checkTc (not is_local) (quoteStageError quoter) + + -- Build the expression + ; let quoterExpr = L q_span $! HsVar $! quoter + ; let quoteExpr = L q_span $! HsLit $! HsString quote + ; let expr = L q_span $ + HsApp (L q_span $ + HsApp (L q_span (HsVar quote_selector)) quoterExpr) quoteExpr + ; recordThUse + ; meta_exp_ty <- tcMetaTy meta_ty + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr expr meta_exp_ty + + -- Run the expression + ; traceTc (text "About to run" <+> ppr zonked_q_expr) + ; result <- runMeta convert zonked_q_expr + ; traceTc (text "Got result" <+> ppr result) + ; showSplice desc zonked_q_expr (ppr result) + ; return result + } + +runQuasiQuoteExpr quasiquote + = runQuasiQuote quasiquote quoteExpName "expression" expQTyConName convertToHsExpr + +runQuasiQuotePat quasiquote + = runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat + +quoteStageError quoter + = sep [ptext SLIT("GHC stage restriction:") <+> ppr quoter, + nest 2 (ptext SLIT("is used in a quasiquote, and must be imported, not defined locally"))] +\end{code} + + +%************************************************************************ +%* * Splicing a type %* * %************************************************************************ @@ -463,6 +544,11 @@ runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) -> TcM (LHsExpr RdrName) runMetaE = runMeta +runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName)) + -> LHsExpr Id -- Of type (Q Pat) + -> TcM (Pat RdrName) +runMetaP = runMeta + runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) -> LHsExpr Id -- Of type (Q Type) -> TcM (LHsType RdrName) @@ -499,9 +585,12 @@ runMeta convert expr -- encounter them inside the try -- -- See Note [Exceptions in TH] - either_tval <- tryAllM $ do - { th_syn <- TH.runQ (unsafeCoerce# hval) - ; case convert (getLoc expr) th_syn of + let expr_span = getLoc expr + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { th_syn <- TH.runQ (unsafeCoerce# hval) + ; case convert expr_span th_syn of Left err -> failWithTc err Right hs_syn -> return hs_syn } @@ -560,10 +649,14 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qReport True msg = addErr (text msg) qReport False msg = addReport (text msg) - qCurrentModule = do { m <- getModule; - return (moduleNameString (moduleName m)) } - -- ToDo: is throwing away the package name ok here? - + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l) + , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } + qReify v = reify v -- For qRecover, discard error messages if diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 02503f3..c9bab4b 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,6 +1,7 @@ \begin{code} module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsDecl ) +import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, + HsExpr, LHsExpr, LPat, LHsDecl ) import Name ( Name ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) @@ -15,4 +16,7 @@ tcBracket :: HsBracket Name -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] + +runQuasiQuoteExpr :: HsQuasiQuote Name.Name -> TcM (LHsExpr RdrName) +runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName) \end{code} diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 3442302..166ff11 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -743,6 +743,12 @@ + + Enable quasiquotation. + dynamic + + + Enable bang patterns. dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 9b4dc58..f22e6c9 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -290,6 +290,17 @@ documentation describes all the libraries that come with GHC. + + + + Enables quasiquotation (see ). + + Syntax stolen: + [:varid|. + + + @@ -4985,6 +4996,15 @@ Wiki page. + A quasi-quotation can appear in either a pattern context or an + expression context and is also written in Oxford brackets: + + [:varid| ... |], + where the "..." is an arbitrary string; a full description of the + quasi-quotation facility is given in . + + + A name can be quoted with either one or two prefix single quotes: 'f has type Name, and names the function f. @@ -5158,6 +5178,124 @@ The basic idea is to compile the program twice: + Template Haskell Quasi-quotation +Quasi-quotation allows patterns and expressions to be written using +programmer-defined concrete syntax; the motivation behind the extension and +several examples are documented in +"Why It's +Nice to be Quoted: Quasiquoting for Haskell" (Proc Haskell Workshop +2007). The example below shows how to write a quasiquoter for a simple +expression language. + + +In the example, the quasiquoter expr is bound to a value of +type Language.Haskell.TH.Quote.QuasiQuoter which contains two +functions for quoting expressions and patterns, respectively. The first argument +to each quoter is the (arbitrary) string enclosed in the Oxford brackets. The +context of the quasi-quotation statement determines which of the two parsers is +called: if the quasi-quotation occurs in an expression context, the expression +parser is called, and if it occurs in a pattern context, the pattern parser is +called. + + +Note that in the example we make use of an antiquoted +variable n, indicated by the syntax 'int:n +(this syntax for anti-quotation was defined by the parser's +author, not by GHC). This binds n to the +integer value argument of the constructor IntExpr when +pattern matching. Please see the referenced paper for further details regarding +anti-quotation as well as the description of a technique that uses SYB to +leverage a single parser of type String -> a to generate both +an expression parser that returns a value of type Q Exp and a +pattern parser that returns a value of type Q Pat. + + +In general, a quasi-quote has the form +[$quoter| string |]. +The quoter must be the name of an imported quoter; it +cannot be an arbitrary expression. The quoted string +can be arbitrary, and may contain newlines. + + +Quasiquoters must obey the same stage restrictions as Template Haskell, e.g., in +the example, expr cannot be defined +in Main.hs where it is used, but must be imported. + + + + +{- Main.hs -} +module Main where + +import Expr + +main :: IO () +main = do { print $ eval [$expr|1 + 2|] + ; case IntExpr 1 of + { [$expr|'int:n|] -> print n + ; _ -> return () + } + } + + +{- Expr.hs -} +module Expr where + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH.Quasi + +data Expr = IntExpr Integer + | AntiIntExpr String + | BinopExpr BinOp Expr Expr + | AntiExpr String + deriving(Show, Typeable, Data) + +data BinOp = AddOp + | SubOp + | MulOp + | DivOp + deriving(Show, Typeable, Data) + +eval :: Expr -> Integer +eval (IntExpr n) = n +eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) + where + opToFun AddOp = (+) + opToFun SubOp = (-) + opToFun MulOp = (*) + opToFun DivOp = div + +expr = QuasiQuoter parseExprExp parseExprPat + +-- Parse an Expr, returning its representation as +-- either a Q Exp or a Q Pat. See the referenced paper +-- for how to use SYB to do this by writing a single +-- parser of type String -> Expr instead of two +-- separate parsers. + +parseExprExp :: String -> Q Exp +parseExprExp ... + +parseExprPat :: String -> Q Pat +parseExprPat ... + + +Now run the compiler: + + +$ ghc --make -XQuasiQuotes Main.hs -o main + + +Run "main" and here is your output: + + +$ ./main +3 +1 + + + +