Commit f3399c44 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.)

parent 206b4dec
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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)
......
......@@ -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]
......
module HsPat where
data HsQuasiQuote i = HsQuasiQuote i i SrcSpan FastString
data Pat i
type LPat i = SrcLoc.Located (Pat i)
......@@ -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
......
\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)
......
......@@ -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}
......
......@@ -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 ),
......
......@@ -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
......@@ -1317,6 +1321,42 @@ getCharOrFail = do
Nothing -> lexError "unexpected end-of-file in string/character literal"
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
......@@ -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
......
......@@ -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)) }
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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)
......
......@@ -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}
%************************************************************************
%* *
......
......@@ -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