Commit 1f5e5580 authored by simonpj's avatar simonpj

[project @ 2003-11-06 17:09:50 by simonpj]

------------------------------------
	Major increment for Template Haskell
	------------------------------------

1.  New abstract data type "Name" which appears where String used to be.
    E.g. 	data Exp = VarE Name | ...

2.  New syntax 'x and ''T, for quoting Names.  It's rather like [| x |]
    and [t| T |] respectively, except that

	a) it's non-monadic:  'x :: Name
	b) you get a Name not an Exp or Type

3.  reify is an ordinary function
	reify :: Name -> Q Info
    New data type Info which tells what TH knows about Name

4.  Local variables work properly.  So this works now (crashed before):
	f x = $( [| x |] )

5.  THSyntax is split up into three modules:

  Language.Haskell.TH		TH "clients" import this

  Language.Haskell.TH.THSyntax	data type declarations and internal stuff

  Language.Haskell.TH.THLib	Support library code (all re-exported
				by TH), including smart constructors and
				pretty printer

6.  Error reporting and recovery are in (not yet well tested)

	report :: Bool {- True <=> fatal -} -> String -> Q ()
	recover :: Q a -> Q a -> Q a

7.  Can find current module

	currentModule :: Q String


Much other cleaning up, needless to say.
parent 599e42c2
......@@ -252,7 +252,7 @@ localiseName n = n { n_sort = Internal }
\begin{code}
hashName :: Name -> Int
hashName name = iBox (getKey (nameUnique name))
hashName name = getKey (nameUnique name)
\end{code}
......
......@@ -26,7 +26,7 @@ module OccName (
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
mkOccName, mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS,
mkVarOcc, mkVarOccEncoded,
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
......@@ -34,7 +34,7 @@ module OccName (
mkGenOcc1, mkGenOcc2, mkLocalOcc, mkDataTOcc, mkDataCOcc,
mkDataConWrapperOcc, mkDataConWorkerOcc,
isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
reportIfUnused,
occNameFS, occNameString, occNameUserString, occNameSpace,
......@@ -200,7 +200,7 @@ pprOccName (OccName sp occ)
%* *
\subsection{Construction}
%* *
%************************************************************************
%*****p*******************************************************************
*Sys* things do no encoding; the caller should ensure that the thing is
already encoded
......@@ -235,6 +235,9 @@ mkKindOccFS occ_sp fs = OccName occ_sp fs
mkOccFS :: NameSpace -> UserFS -> OccName
mkOccFS occ_sp fs = mkSysOccFS occ_sp (encodeFS fs)
mkOccName :: NameSpace -> String -> OccName
mkOccName ns s = mkSysOcc ns (encode s)
mkVarOcc :: UserFS -> OccName
mkVarOcc fs = mkSysOccFS varName (encodeFS fs)
......@@ -372,7 +375,10 @@ briefNameSpaceFlavour TcClsName = "tc"
\end{code}
\begin{code}
isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
isVarOcc, isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
isVarOcc (OccName VarName _) = True
isVarOcc other = False
isTvOcc (OccName TvName _) = True
isTvOcc other = False
......
......@@ -300,9 +300,9 @@ extendLocalRdrEnv env names
= extendOccEnvList env [(nameOccName n, n) | n <- names]
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv env rdr_name
| isUnqual rdr_name = lookupOccEnv env (rdrNameOcc rdr_name)
| otherwise = Nothing
lookupLocalRdrEnv env (Exact name) = Just name
lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ
lookupLocalRdrEnv env other = Nothing
elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
elemLocalRdrEnv rdr_name env
......
......@@ -90,8 +90,8 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\end{code}
\begin{code}
uniqFromSupply (MkSplitUniqSupply (I# n) _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply (I# n) _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n
uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2
\end{code}
%************************************************************************
......
......@@ -22,7 +22,8 @@ module Unique (
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
getKey, -- Used in Var, UniqFM, Name only!
getKey, getKey#, -- Used in Var, UniqFM, Name only!
unpkUnique,
incrUnique, -- Used for renumbering
deriveUnique, -- Ditto
......@@ -77,9 +78,9 @@ The stuff about unique *supplies* is handled further down this module.
mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int# -- for Var
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
getKey# :: Unique -> Int# -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
......@@ -90,10 +91,12 @@ isTupleKey :: Unique -> Bool
\begin{code}
mkUniqueGrimily x = MkUnique x
mkUniqueGrimily (I# x) = MkUnique x
{-# INLINE getKey #-}
getKey (MkUnique x) = x
getKey (MkUnique x) = I# x
{-# INLINE getKey# #-}
getKey# (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i +# 1#)
......@@ -152,10 +155,10 @@ hasKey :: Uniquable a => a -> Unique -> Bool
x `hasKey` k = getUnique x == k
instance Uniquable FastString where
getUnique fs = mkUniqueGrimily (uniqueOfFS fs)
getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs))
instance Uniquable Int where
getUnique (I# i#) = mkUniqueGrimily i#
getUnique i = mkUniqueGrimily i
\end{code}
......
......@@ -43,7 +43,7 @@ import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique,
mkSystemTvNameEncoded,
)
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
......@@ -143,16 +143,16 @@ instance Ord Var where
\begin{code}
varUnique :: Var -> Unique
varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq
varUnique (Var {realUnique = uniq}) = mkUniqueGrimily (iBox uniq)
setVarUnique :: Var -> Unique -> Var
setVarUnique var@(Var {varName = name}) uniq
= var {realUnique = getKey uniq,
= var {realUnique = getKey# uniq,
varName = setNameUnique name uniq}
setVarName :: Var -> Name -> Var
setVarName var new_name
= var { realUnique = getKey (getUnique new_name), varName = new_name }
= var { realUnique = getKey# (getUnique new_name), varName = new_name }
setVarOcc :: Var -> OccName -> Var
setVarOcc var new_occ
......@@ -184,7 +184,7 @@ setTyVarName = setVarName
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = Var { varName = name
, realUnique = getKey (nameUnique name)
, realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkTyVar" (ppr name)
......@@ -192,7 +192,7 @@ mkTyVar name kind = Var { varName = name
mkSysTyVar :: Unique -> Kind -> TyVar
mkSysTyVar uniq kind = Var { varName = name
, realUnique = getKey uniq
, realUnique = getKey# uniq
, varType = kind
, varDetails = TyVar
, varInfo = pprPanic "mkSysTyVar" (ppr name)
......@@ -203,7 +203,7 @@ mkSysTyVar uniq kind = Var { varName = name
mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar
mkMutTyVar name kind details ref
= Var { varName = name
, realUnique = getKey (nameUnique name)
, realUnique = getKey# (nameUnique name)
, varType = kind
, varDetails = MutTyVar ref details
, varInfo = pprPanic "newMutTyVar" (ppr name)
......@@ -284,7 +284,7 @@ maybeModifyIdInfo fn var@(Var {varInfo = info}) = case fn info of
mkId :: Name -> Type -> VarDetails -> IdInfo -> Id
mkId name ty details info
= Var { varName = name,
realUnique = getKey (nameUnique name), -- Cache the unique
realUnique = getKey# (nameUnique name), -- Cache the unique
varType = ty,
varDetails = details,
varInfo = info }
......
......@@ -22,7 +22,7 @@ import DsMonad
#ifdef GHCI
-- Template Haskell stuff iff bootstrapped
import DsMeta ( dsBracket, dsReify )
import DsMeta ( dsBracket )
#endif
import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..),
......@@ -555,7 +555,6 @@ Here is where we desugar the Template Haskell brackets and escapes
#ifdef GHCI /* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
dsExpr (HsReify r) = dsReify r
dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
......
......@@ -102,8 +102,8 @@ dsForeigns fos
warnDepr False _ = returnDs ()
warnDepr True loc = dsWarn (loc, msg)
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
......
This diff is collapsed.
......@@ -90,7 +90,7 @@ type DsMetaEnv = NameEnv DsMetaVal
data DsMetaVal
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
-- The Id has type String
-- The Id has type THSyntax.Var
| Splice TypecheckedHsExpr -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
......@@ -174,7 +174,9 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a
putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
dsWarn :: DsWarning -> DsM ()
dsWarn warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` warn) }
dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
where
msg = ptext SLIT("Warning:") <+> warn
\end{code}
\begin{code}
......
This diff is collapsed.
......@@ -191,8 +191,6 @@ data HsExpr id
-- The id is just a unique name to
-- identify this splice point
| HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity
-----------------------------------------------------------
-- Arrow notation extension
......@@ -443,7 +441,6 @@ ppr_expr (HsType id) = ppr id
ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b _) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
ppr_expr (HsReify r) = ppr r
ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _)
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd]
......@@ -833,22 +830,6 @@ pprHsBracket (VarBr n) = char '\'' <> ppr n
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext SLIT("|]")
data HsReify id = Reify ReifyFlavour id -- Pre typechecking
| ReifyOut ReifyFlavour Name -- Post typechecking
-- The Name could be the name of
-- an Id, TyCon, or Class
data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity
instance Outputable id => Outputable (HsReify id) where
ppr (Reify flavour id) = ppr flavour <+> ppr id
ppr (ReifyOut flavour thing) = ppr flavour <+> ppr thing
instance Outputable ReifyFlavour where
ppr ReifyDecl = ptext SLIT("reifyDecl")
ppr ReifyType = ptext SLIT("reifyType")
ppr ReifyFixity = ptext SLIT("reifyFixity")
\end{code}
%************************************************************************
......
......@@ -29,7 +29,7 @@ import HscTypes ( HscEnv(..), ModIface(..), emptyModIface,
lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
Pool(..), DeclPool, InstPool,
RulePool, Gated, addRuleToPool, RulePoolContents
RulePool, addRuleToPool, RulePoolContents
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
......
......@@ -9,7 +9,7 @@ module ErrUtils (
Messages, errorsFound, emptyMessages,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine, addWarnLocHdrLine,
addErrLocHdrLine,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
......@@ -50,7 +50,6 @@ addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg
-- Be refined about qualification, return an ErrMsg
addErrLocHdrLine :: SrcLoc -> Message -> Message -> Message
addWarnLocHdrLine :: SrcLoc -> Message -> Message -> Message
-- Used by Lint and other system stuff
-- Always print qualified, return a Message
......@@ -67,18 +66,11 @@ addShortWarnLocLine locn print_unqual msg
addErrLocHdrLine locn hdr msg
= mkErrDoc locn (hdr $$ msg)
addWarnLocHdrLine locn hdr msg
= mkWarnDoc locn (hdr $$ msg)
mkErrDoc locn msg
| isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg
| otherwise = msg
mkWarnDoc locn msg
| isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg
| otherwise = warn_msg
where
warn_msg = ptext SLIT("Warning:") <+> msg
mkWarnDoc locn msg = mkErrDoc locn msg
\end{code}
\begin{code}
......
......@@ -421,9 +421,8 @@ data Token__
| ITcloseQuote -- |]
| ITidEscape FastString -- $x
| ITparenEscape -- $(
| ITreifyType
| ITreifyDecl
| ITreifyFixity
| ITvarQuote -- '
| ITtyQuote -- ''
-- Arrow notation extension
| ITproc
......@@ -498,9 +497,6 @@ reservedWordsFM = listToUFM $
( "forall", ITforall, bit glaExtsBit),
( "mdo", ITmdo, bit glaExtsBit),
( "reifyDecl", ITreifyDecl, bit thBit),
( "reifyType", ITreifyType, bit thBit),
( "reifyFixity",ITreifyFixity, bit thBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
......@@ -862,6 +858,13 @@ lex_string s = do
c <- lex_char
lex_string (c:s)
lex_char :: P Char
lex_char = do
mc <- getCharOrFail
case mc of
'\\' -> lex_escape
c | is_any c -> return c
_other -> lit_error
lex_stringgap s = do
c <- getCharOrFail
......@@ -872,34 +875,61 @@ lex_stringgap s = do
lex_char_tok :: Action
lex_char_tok loc _end buf len = do
c <- lex_char
mc <- getCharOrFail
case mc of
'\'' -> do
glaexts <- extension glaExtsEnabled
if glaexts
then do
i@(end,_) <- getInput
case alexGetChar i of
-- Here we are basically parsing character literals, such as 'x' or '\n'
-- but, when Template Haskell is on, we additionally spot
-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
-- but WIHTOUT CONSUMING the x or T part (the parser does that).
-- So we have to do two characters of lookahead: when we see 'x we need to
-- see if there's a trailing quote
lex_char_tok loc _end buf len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
case alexGetChar i1 of
Nothing -> lit_error
Just ('\'', i2@(end2,_)) -> do -- We've seen ''
th_exts <- extension thEnabled
if th_exts then do
setInput i2
return (T loc end2 ITtyQuote)
else lit_error
Just ('\\', i2@(end2,_)) -> do -- We've seen 'backslash
setInput i2
lit_ch <- lex_escape
mc <- getCharOrFail -- Trailing quote
if mc == '\'' then finish_char_tok loc lit_ch
else lit_error
Just (c, i2@(end2,_)) | not (is_any c) -> lit_error
| otherwise ->
-- We've seen 'x, where x is a valid character
-- (i.e. not newline etc) but not a quote or backslash
case alexGetChar i2 of -- Look ahead one more character
Nothing -> lit_error
Just ('\'', i3) -> do -- We've seen 'x'
setInput i3
finish_char_tok loc c
_other -> do -- We've seen 'x not followed by quote
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
if th_exts then return (T loc (fst i1) ITvarQuote)
else lit_error
finish_char_tok :: SrcLoc -> Char -> P Token
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do glaexts <- extension glaExtsEnabled
if glaexts then do
i@(end,_) <- getInput
case alexGetChar i of
Just ('#',i@(end,_)) -> do
setInput i
return (T loc end (ITprimchar c))
return (T loc end (ITprimchar ch))
_other ->
return (T loc end (ITchar c))
else do
end <- getSrcLoc
return (T loc end (ITchar c))
_other -> lit_error
lex_char :: P Char
lex_char = do
mc <- getCharOrFail
case mc of
'\\' -> lex_escape
c | is_any c -> return c
_other -> lit_error
return (T loc end (ITchar ch))
else do end <- getSrcLoc
return (T loc end (ITchar ch))
lex_escape :: P Char
lex_escape = do
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.128 2003/11/04 13:14:06 simonpj Exp $
$Id: Parser.y,v 1.129 2003/11/06 17:09:53 simonpj Exp $
Haskell grammar.
......@@ -208,11 +208,10 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
'[t|' { T _ _ ITopenTypQuote }
'[d|' { T _ _ ITopenDecQuote }
'|]' { T _ _ ITcloseQuote }
ID_SPLICE { T _ _ (ITidEscape $$) } -- $x
TH_ID_SPLICE { T _ _ (ITidEscape $$) } -- $x
'$(' { T _ _ ITparenEscape } -- $( exp )
REIFY_TYPE { T _ _ ITreifyType }
REIFY_DECL { T _ _ ITreifyDecl }
REIFY_FIXITY { T _ _ ITreifyFixity }
TH_VAR_QUOTE { T _ _ ITvarQuote } -- 'x
TH_TY_QUOTE { T _ _ ITtyQuote } -- ''T
%monad { P } { >>= } { return }
%lexer { lexer } { T _ _ ITeof }
......@@ -932,7 +931,6 @@ exp10 :: { RdrNameHsExpr }
| '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation
| reifyexp { HsReify $1 }
| fexp { $1 }
scc_annot :: { FastString }
......@@ -943,12 +941,6 @@ fexp :: { RdrNameHsExpr }
: fexp aexp { HsApp $1 $2 }
| aexp { $1 }
reifyexp :: { HsReify RdrName }
: REIFY_DECL gtycon { Reify ReifyDecl $2 }
| REIFY_DECL qvar { Reify ReifyDecl $2 }
| REIFY_TYPE qcname { Reify ReifyType $2 }
| REIFY_FIXITY qcname { Reify ReifyFixity $2 }
aexps :: { [RdrNameHsExpr] }
: aexps aexp { $2 : $1 }
| {- empty -} { [] }
......@@ -985,8 +977,12 @@ aexp2 :: { RdrNameHsExpr }
| '_' { EWildPat }
-- MetaHaskell Extension
| srcloc ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
| srcloc TH_ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x
| srcloc '$(' exp ')' { mkHsSplice $3 $1 } -- $( exp )
| srcloc TH_VAR_QUOTE qvar { HsBracket (VarBr $3) $1 }
| srcloc TH_VAR_QUOTE qcon { HsBracket (VarBr $3) $1 }
| srcloc TH_TY_QUOTE tyvar { HsBracket (VarBr $3) $1 }
| srcloc TH_TY_QUOTE gtycon { HsBracket (VarBr $3) $1 }
| srcloc '[|' exp '|]' { HsBracket (ExpBr $3) $1 }
| srcloc '[t|' ctype '|]' { HsBracket (TypBr $3) $1 }
| srcloc '[p|' infixexp '|]' {% checkPattern $1 $3 >>= \p ->
......
......@@ -315,9 +315,6 @@ dOTNET = mkBasePkgModule dOTNET_Name
gLA_EXTS = mkBasePkgModule gLA_EXTS_Name
mONAD_FIX = mkBasePkgModule mONAD_FIX_Name
-- MetaHaskell Extension text2 from Meta/work/gen.hs
mETA_META_Name = mkModuleName "Language.Haskell.THSyntax"
rOOT_MAIN_Name = mkModuleName ":Main" -- Root module for initialisation
rOOT_MAIN = mkHomeModule rOOT_MAIN_Name
-- The ':xxx' makes a moudle name that the user can never
......
......@@ -42,7 +42,7 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName,
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
nameSrcLoc, nameOccName, nameModuleName, nameParent )
import NameSet
import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
......@@ -124,10 +124,10 @@ lookupTopBndrRn :: RdrName -> RnM Name
lookupTopBndrRn rdr_name
| Just name <- isExact_maybe rdr_name
-- This is here just to catch the PrelBase defn of (say) [] and similar
-- The parser reads the special syntax and returns an Exact RdrName
-- But the global_env contains only Qual RdrNames, so we won't
-- find it there; instead just get the name via the Orig route
-- This is here to catch
-- (a) Exact-name binders created by Template Haskell
-- (b) The PrelBase defn of (say) [] and similar, for which
-- the parser reads the special syntax and returns an Exact RdrName
--
-- We are at a binding site for the name, so check first that it
-- the current module is the correct one; otherwise GHC can get
......@@ -135,7 +135,7 @@ lookupTopBndrRn rdr_name
-- data T = (,) Int Int
-- unless we are in GHC.Tup
= getModule `thenM` \ mod ->
checkErr (moduleName mod == nameModuleName name)
checkErr (isInternalName name || moduleName mod == nameModuleName name)
(badOrigBinding rdr_name) `thenM_`
returnM name
......@@ -492,29 +492,25 @@ lookupSyntaxNames std_names
%*********************************************************
\begin{code}
newLocalsRn :: [(RdrName,SrcLoc)]
-> RnM [Name]
newLocalsRn :: [(RdrName,SrcLoc)] -> RnM [Name]
newLocalsRn rdr_names_w_loc
= newUniqueSupply `thenM` \ us ->
let
uniqs = uniqsFromSupply us
names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
returnM names
= newUniqueSupply `thenM` \ us ->
returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us))
where
mk (rdr_name, loc) uniq
| Just name <- isExact_maybe rdr_name = name
-- This happens in code generated by Template Haskell
| otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name )
-- We only bind unqualified names here
-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
mkInternalName uniq (rdrNameOcc rdr_name) loc
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [(RdrName,SrcLoc)]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
= ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc )
-- We only bind unqualified names here
-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
-- Check for duplicate names
= -- Check for duplicate names
checkDupNames doc_str rdr_names_w_loc `thenM_`
-- Warn about shadowing, but only in source modules
......
......@@ -228,12 +228,6 @@ rnExpr e@(HsSplice n splice loc)
rnExpr splice `thenM` \ (splice', fvs_e) ->
returnM (HsSplice n' splice' loc, fvs_e)
rnExpr e@(HsReify (Reify flavour name))
= checkTH e "reify" `thenM_`
lookupGlobalOccRn name `thenM` \ name' ->
-- For now, we can only reify top-level things
returnM (HsReify (Reify flavour name'), unitFV name')
rnExpr section@(SectionL expr op)
= rnExpr expr `thenM` \ (expr', fvs_expr) ->
rnExpr op `thenM` \ (op', fvs_op) ->
......@@ -625,6 +619,8 @@ rnRbinds str rbinds
%************************************************************************
\begin{code}
rnBracket (VarBr n) = lookupOccRn n `thenM` \ name ->
returnM (VarBr name, unitFV name)
rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) ->
returnM (ExpBr e', fvs)
rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) ->
......
......@@ -87,7 +87,9 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
$ do {
-- Rename other declarations
traceRn (text "Start rnmono") ;
(rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ;
traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
-- You might think that we could build proper def/use information
-- for type and class declarations, but they can be involved
......@@ -117,6 +119,7 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
src_dus = bind_dus `plusDU` usesOnly other_fvs
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
tcg_env <- getGblEnv ;
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
......
......@@ -61,7 +61,7 @@ import Var ( TyVar )
import PrelNames ( genericTyConNames )
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import ErrUtils ( dumpIfSet_dyn )
import Util ( count, lengthIs, isSingleton, lengthExceeds )
import Unique ( Uniquable(..) )
import ListSetOps ( equivClassesByUniq, minusList )
......
......@@ -10,7 +10,6 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
import HsSyn ( HsReify(..), ReifyFlavour(..) )
import Id ( Id )
import TcType ( isTauTy )
import TcEnv ( tcMetaTy, checkWellStaged )
......@@ -564,17 +563,6 @@ tcMonoExpr (PArrSeqIn _) _
tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty)
tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty)
tcMonoExpr (HsReify (Reify flavour name)) res_ty
= addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
tcMetaTy tycon_name `thenM` \ reify_ty ->
zapExpectedTo res_ty reify_ty `thenM_`
returnM (HsReify (ReifyOut flavour name))
where
tycon_name = case flavour of
ReifyDecl -> DsMeta.decQTyConName
ReifyType -> DsMeta.typeQTyConName
ReifyFixity -> pprPanic "tcMonoExpr: cant do reifyFixity yet" (ppr name)
#endif /* GHCI */
\end{code}
......
......@@ -508,8 +508,6 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
returnM (n,e')
zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
-- level things can be reified (for now)
zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
returnM (HsSplice n e loc)
......
......@@ -43,14 +43,12 @@ import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..),
mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
liftedTypeKind, unliftedTypeKind, eqKind,
tcSplitFunTy_maybe, tcSplitForAllTys, tcSplitSigmaTy,
pprKind, pprThetaArrow )
tcSplitFunTy_maybe, tcSplitForAllTys, pprKind )
import qualified Type ( splitFunTys )
import Inst ( Inst, InstOrigin(..), newMethod, instToId )
import Id ( mkLocalId, idName, idType )
import Var ( TyVar, mkTyVar, tyVarKind )
import ErrUtils ( Message )
import TyCon ( TyCon, tyConKind )
import Class ( classTyCon )
import Name ( Name )
......
......@@ -688,6 +688,7 @@ rnTopSrcDecls group
tcg_imports = imports `plusImportAvails` tcg_imports gbl })
$ do {
traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
......
......@@ -385,8 +385,8 @@ addErrs msgs = mappM_ add msgs
where
add (loc,msg) = addErrAt loc msg
addWarn :: Message -> TcRn ()
addWarn msg
addReport :: Message -> TcRn ()
addReport msg
= do { errs_var <- getErrsVar ;
loc <- getSrcLocM ;
rdr_env <- getGlobalRdrEnv ;
......@@ -394,6 +394,9 @@ addWarn msg
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns `snocBag` warn, errs) }
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)
checkErr :: Bool -> Message -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)
......
This diff is collapsed.
......@@ -30,7 +30,7 @@ module TcUnify (
import HsSyn ( HsExpr(..) )
import TcHsSyn ( mkHsLet,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon, isSuperKind )
import TypeRep ( Type(..), PredType(..), TyNote(..), openKindCon, isSuperKind )
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
......
......@@ -48,7 +48,7 @@ module UniqFM (
import {-# SOURCE #-} Name ( Name )